diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,2828 @@ +# 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) + +## [Unreleased] + +## [1.9.0] - 2026-11-10 + +### Added + +- `--fleet` (`FLEET`): servers that share a Redis answer as one. Every + request is answered from the newest block that all live servers have and + from one mempool that they share in Redis, so that the same request gets + the same answer whichever server a load balancer picks, also while a + block or a transaction is on its way through them. + - Each server keeps its database as it was at each of its last six + blocks, reports them under a lease of ten seconds, and offers its + unconfirmed transactions to the shared pool. The fleet tip moves in one + step, together with what the blocks in between did to the pool. + - A server that does not have the block that the fleet answers from says + 503 with `behind-fleet`. One whose health check fails stops reporting, + and stops counting when its lease runs out. + - Without Redis a server answers from its own database and `/health` says + 203. + - `Haskoin.Store.Manager` runs the member (`Store.fleet`), the block + store takes a view of the database right after each block + (`BlockStoreConfig.onBest`), and the web server answers through + `Haskoin.Store.Database.Query.Pooled`. + - An integration test runs two servers as a fleet against a real node and + Redis and compares their answers with a payment in the pool and after + the block that confirms it. + - `docs/layered-database/FleetCost.hs` times a store alone against the + same store in a fleet, with 40,000 transactions in the pool: a fleet + adds about one round trip to Redis to a request. A request is answered + from the tip that the member last read, which its first read of the + pool checks; a transaction's body comes with what spends its outputs; + and a first page is as large as the page asked for. + +- A cache of xpubs for a fleet (`Haskoin.Store.Fleet.XPub`), under the + options of the cache of a server alone: `--redis-min-addrs`, + `--redis-min-txs` and `--redis-max-xpubs`. Until now `--fleet` answered + every request about an xpub from the database, with a read of the shared + pool for each address that it touches. + - An entry has the chain's part of a wallet at one block, which is the + same for the whole cache, and the part of the shared pool, which the + script of the pool keeps as it changes the pool. Transactions and + outputs of both are in one sorted set each, in the order of the API. + - The cache answers only while its block is the fleet tip. The server + that moves the tip brings the cache along, with what the new blocks + did at the addresses that entries have. If it does not, or after a + reorganisation, the cache is emptied. + - The cache is at a move of the fleet tip, which the pool counts, and + not just at a block: the tip can leave a block and come back to it. + - Every read of balances runs the scan of the xpub over the entry and + misses unless it reads exactly the addresses of the entry, so a + payment in the pool to an unused address cannot leave the gap wrong. + - Entries are built in the background by the server that missed, and + extended when an xpub gains addresses. + - A request about a wallet of 464 addresses and 19,499 transactions + takes 1.3 to 2.2 milliseconds through it, where a fleet took 5 to 38; + for a wallet with 400 addresses in the pool, 3 to 4 where it took 5 to + 126 (`docs/layered-database/fleet-cost.txt`). + - The test of the member compares every answer about a wallet through + the cache with the uncached one after each step of random histories, + and the two servers of the integration test do the same over HTTP. + - StatsD metrics under `fleet.cache.*`: hits, misses, builds and their + time, builds given up, evictions, and the times that the cache was + emptied. The log says why the cache was emptied each time, and with + `--debug` has a line for each entry built and each block that the + cache was brought to. +- Built with `rocksdb-haskell-jprupp` 2.7.1, and every scan by address + uses an iterator that RocksDB stops where the address ends, so that a + scan cannot walk over deleted keys that follow it. The migration reads + the transactions with an iterator that is asked for the order of them + all. +- Built with `haskoin-node` 2.5.0, which has the fixes of its security + review: among them, a block from a peer is checked against its header + before the store sees it, so a peer can no longer pass off transactions + of its choice under a real header. It also allows the new binding. On + regtest its discovery no longer finds a node on this machine: name the + node with `--peer`. +- **`/events` agrees across a fleet.** The servers of a fleet send the + events of the block and the mempool that they share, read from a stream + in Redis that the pool's script writes as it makes each change, and no + longer those of their own nodes. A block is told when the fleet has + moved to it, with every block that it moved through. +- **`/events` takes up where a client left.** `?after=` with the hash of + the last event heard starts the stream after it, over HTTP and over the + WebSocket. The server keeps its last 10,000 events in one log that all + clients read (`Haskoin.Store.Web.Events`), in place of a queue for each. + It answers 404 when it does not have the event. The servers of a fleet + keep the same events, so a client may come back to another one. +- **A WebSocket client chooses the transactions it hears about**: by + address, by extended public key with a type of address, or with a Bloom + filter as in BIP 37, with the commands of `EventCommand` in + `haskoin-store-data` 1.11. Blocks are always sent, and a client that + sends no command hears everything, as before. A key is watched up to its + gap, which moves on with its payments. +- **The choice can be in the URL of `/events`**, so that it holds from + the first event: `quiet=true` for blocks alone, `addresses`, `xpub` with + `derive` (one type or several), and `filter` with `functions`, `tweak` + and `flags`. The HTTP stream takes them too, also under `POST` with a + form. `{"type":"none"}` goes back to blocks alone. +- **The WebSocket speaks binary too**: binary frames when the handshake + asks for binary or the client sends a binary frame, for events and + commands alike. +- **HTTPS**, optional and off by default: `--tls-cert` and `--tls-key` + (`TLS_CERT`, `TLS_KEY`) make the server speak HTTPS on its port. +- **The reference of the API at the root of the server.** `/` is a page + that shows `swagger.yaml` as it was when the server was built, and can + try requests against it; `/swagger.yaml` is the file. +- **`HEAD` and `OPTIONS`** are answered: the headers of what `GET` gives, + and what a browser may send from another site. +- **Answers are compressed** with gzip for clients that accept it, but for + the stream of events. +- **Lists in a body.** The endpoints that take a list of addresses, + blocks, heights or transactions accept `POST` with the parameters in a + form, so that a long list need not fit in a URL. +- **`Retry-After`** on every 503. +- **Errors in binary.** A request that asks for the binary format gets + its errors in that format too, the 503 of a server behind its fleet + included. They were JSON whatever was asked. This needs + `haskoin-store-data` 1.10, whose client reads both. +- **The `Accept` header is read as a list with weights.** Binary is sent + when `application/octet-stream` is listed with a weight above 0 that is + no less than that of `application/json`. The header used to be compared + with that one string, so a list or a weight silently gave JSON. Every + answer has `Vary: Accept`. +- **The raw lists start with a count**, in binary: `/transactions/raw`, + `/block/{block}/transactions/raw` and `/block/height/{height}/raw` were + the one kind of list without it. A binary client of those three + endpoints has to change with the server. +- `haskoin-store --help` names the environment variable of every option. +- `swagger.yaml` documents the binary format: how to ask for it, the + encoding of each type that the API returns, and what differs from JSON. +- Gauges `fleet.cache.xpubs` and `fleet.cache.addresses`: how many xpubs + the cache of a fleet holds, and how many addresses between them. + +### Changed + +- A WebSocket client of `/events` that sends something the server cannot + read as a command is disconnected, with code 1008 and the reason. What + clients sent used to be ignored. +- The HTTP stream of `/events` no longer holds a view of the database for + as long as its client listens. + +- Since version 2.6.4 the binding reads the key and the value of a row of + an iterator without the cost of a safe foreign call. + Every list and every count takes between a half and a third of the time: + the first 100 transactions of a busy address 221 microseconds instead of + 575, and the number of transactions of a wallet with 19,499 of them 34 + milliseconds instead of 78. +- **Bloom filters are on by default**, as was always meant: until the + binding was fixed, `--bloom` built none. `--no-bloom`, or `BLOOM=false`, + turns them off; `--bloom` is still accepted. An existing database gets + filters, and the memory that they take in the block cache, as its table + files are written again. +- **Transactions that leave the mempool unconfirmed are no longer kept.** + The API already answered 404 for them, but their bodies stayed in the + database, marked as deleted, for ever, and each server had its own. + - A server remembers the last hundred thousand that it deleted, in + memory, so as not to fetch them again from its peers. The fleet's rule + for conflicting transactions and the cache of a server alone, which + both asked the database whether a transaction had been deleted, ask + that memory instead. + - The cache of a server alone takes a transaction that Redis has as + unconfirmed for more than ten minutes, and that the database does not + have, for deleted and not for one that it has not seen yet. + - Bodies that version 20 marked as deleted stay in a migrated database + and are ignored. A page that starts at a deleted transaction is empty. +- Removed reports that no longer describe the store: five intermediate + stress runs, the measurement of a mempool mirrored in memory, and the + superseded runs in `docs/layered-database/query-cost.txt`. + `docs/layered-database.md` is rewritten as a description of what + exists, a quarter of its length. +- **Database version 22: the record of a confirmed transaction is written + once**, by the block that confirms it, and is the same on every server + that has the block, so that what the chain's column families hold + follows from the chain alone. + - **Its time is the time of its block.** A server that had seen a + transaction in its mempool used to keep the time of that when a block + confirmed it: two servers then gave two values of `time` for the same + confirmed transaction, which the servers of a fleet must not do. A + transaction that returns to the mempool when its block leaves the main + chain has the time of that block there. + - **The spenders of its outputs are under keys of their own**, in the + `spender` column family, sixteen outputs to a key (`SpenderKey`). + They were in the record, which each block that spent one of its + outputs read and wrote whole again. A spend now reads and writes a + value of a few dozen bytes and leaves the record alone. + - Reading a confirmed transaction in full takes a second key: 18 + microseconds where it took 11.5, and 0.8 milliseconds for a hundred + where it took 0.4. Lists by address and by xpub cost the same, and so + does writing, on the small records of the measurements. + - A database of version 21 is migrated the first time the store opens + it (`migrateRecords`). **It reads every transaction of the database + and writes nearly every one again**, since nothing lists those that + need it and most have a spender in them: many hours for a database of + Bitcoin, and room for a second copy of its transactions until RocksDB + has compacted the first away. The log says how far it is, and it can + be interrupted and started again. + - The tests that run the store through random histories now choose them + from a database of version 20 that goes through the same + (`withShadow`). Given a layered database, the chooser found next to + nothing in the mempool, and the blocks of the tests of the fleet + confirmed almost none of it. +- **Database version 21: the mempool has an area of its own.** Unconfirmed + transactions are no longer written into the indices of the chain. They + are kept apart and applied on top when a query is answered + (`docs/layered-database.md`), so the chain's data changes only when a + block is imported or reverted. + - A database of version 20 is migrated the first time the store opens it, + and the log says how many mempool transactions were moved. **Older + stores refuse the database afterwards**: copy a production database + before upgrading. + - The block store imports with the rules of `Haskoin.Store.Logic.Layered`. + A block that spends an output of a transaction that is only in the + mempool is refused as an orphan; no valid block does that. + - Each request of the web server reads one snapshot of the database for + everything it answers, so the parts of a response agree with each + other. `routerScoped` in `Haskoin.Store.Web.Router` is what gives a + request its snapshot. + - `--wipe-mempool` deletes the keys of the mempool area, in less time + than it took to delete each transaction by the rules, and it no longer + keeps the wiped transactions as deleted ones. + - `StoreRead` has a new query, `getAddressesTxCount`. + - Programs that embed the store and read its database with + `Haskoin.Store.Database.Query` have to move to + `Haskoin.Store.Database.Query.Layered`: the old queries do not see the + mempool of a database of version 21. +- Xpub addresses are derived up to an exact gap: every address up to the last + used one of each chain, then exactly `--xpub-gap` unused ones, and always + the first `--xpub-gap-init` addresses. Addresses used to be read 32 at a + time with the gap checked between batches, so the store looked between 33 + and 64 addresses past the last used one, and started counting again at index + 20. This is why api.haskoin.com saw a payment 34 addresses past the last + used one, which wallets with a gap of 20 or 32 do not see. Payments that far + away are no longer seen; raise `--xpub-gap` to see them. +- New Redis cache of xpubs (`Haskoin.Store.Cache`), replacing the old one: + - Whenever a transaction touches a cached xpub, or a reorganisation changes + one of its transactions, the store reads the whole xpub again from its + database and replaces the entry in one Lua script, so cached answers are + always answers of the database. + - Everything a response needs is in Redis, transaction bodies included, + shared between xpubs, with the spenders of their outputs kept up to date. + A store that has not imported a transaction yet still serves it. + - Several stores can share one Redis. Each change of a cached xpub is + claimed and applied once, by the first store to see it; stores that catch + up find their changes done and do no work. A store never replaces an entry + that knows more than its database (a higher block, or a transaction it has + not seen), so stores do not undo each other's work, and every entry is + written together with the bodies it needs, so a store that is behind can + serve it in full. + - The rules for claims and for replacing entries are pure decisions + (`Haskoin.Store.Cache.Protocol`). A model test runs several stores + catching up with a chain in random interleavings against a model of + Redis, and checks that they end with the entry of the tip, that no + store replaces an entry with one that knows less, that each change is + written once, and that stores catching up after the first write nothing. + - A reload writes only the differences between the xpub in the database + and its entry in Redis, read in chunks first, instead of rewriting the + whole entry; its script checks that the entry did not change since. + Rewriting an xpub of 15,000 transactions held Redis for up to 77 ms, + during which it answered no other client. A store reloads up to four + xpubs at once. + - A page of the transactions or unspent outputs of a cached xpub is one + round trip to Redis: a Lua script finds where it starts, from the + position of the start transaction in the xpub itself, and reads it. + It took four or five, and read the whole body of the start + transaction to find its position. + - A store marks a cached xpub as used at most every ten seconds, for + eviction, instead of on every read, which made every read a write. + - `--redis-min-txs` (`REDIS_MIN_TXS`, default 1000) also caches xpubs + with at least that many transactions in their addresses, however few + addresses they have. + - Keys start with `hs2::`, so the cache can share a Redis with the + cache of older versions and with stores of other networks. + - `--redis-max-xpubs` (`REDIS_MAX_XPUBS`, default 10000) replaces + `--redis-max-keys`: the least recently used xpubs past this many are + evicted. `--redis-sync-interval` is removed. + - StatsD metrics: `cache.hits`, `cache.misses`, `cache.reloads`, + `cache.stale`, `cache.evictions` and `cache.reload` (milliseconds). +- `n_tx` of `/blockchain/multiaddr` counts every transaction of the shown + addresses and xpubs, not only those on the page, and `n_tx_filtered` those + that pass the filter. `n_tx` of `/blockchain/rawaddr` for an xpub is its + number of transactions, not the size of the page. +- The web server runs directly on WAI and Warp, without Scotty. Routes, + parameters and passing a request to the next route are in + `Haskoin.Store.Web.Router`, a small router over WAI; a handler is a plain + function from the state of the server and the request to a response in + `IO`, and stops early by throwing an `Except`, which becomes the JSON + error. Every response carries `Access-Control-Allow-Origin: *`, error + responses included. The endpoints, their parameters and their responses + are as before. +- No monad transformers, except conduits, and no functions polymorphic over + `MonadIO` or `MonadUnliftIO`: everything runs in plain `IO`. Database queries are + functions that take the `DatabaseReader` (`Haskoin.Store.Database.Query`); + imports take a `Writer` handle (`Haskoin.Store.Database.Writer`, + `Haskoin.Store.Logic`); the block store and the manager pass their state + explicitly. The classes `StoreReadBase` and `StoreReadExtra` are replaced + by `StoreRead`, a record of the same queries as functions in `IO`, which + `databaseRead` gives for a database; `getTransaction` and the other + helpers of `Haskoin.Store.Common` take it as their first argument. The state + of the web server, which every handler takes as an argument instead of + reading it from a `ReaderT`, holds the queries to answer with, the cache + in front of those about xpubs; + `nocache=true` gives a handler a state whose queries read only the + database. `withStore`, `runWeb`, `runWebSocket` and the `blockStore*` + functions are in `IO`. `WriterT`, `ImportM`, the `StoreWrite` class, + `BlockT`, `CacheT`, `DatabaseReaderT` and `withDB` were removed earlier + in this release. This changes the library API. +- The package uses the GHC2024 edition, with `DuplicateRecordFields`, + `NoFieldSelectors`, `OverloadedRecordDot` and `OverloadedStrings` on for + every module, and explicit deriving strategies. + +- haskoin-store-data moves to its own repository, + [jprupp/haskoin-store-data](https://github.com/jprupp/haskoin-store-data), + with its history and its own releases, and haskoin-store moves to the root + of this one; `store/` and `data/` are gone. haskoin-store depends on + `haskoin-store-data ^>= 1.9`. The package has a full description, PVP + upper bounds on every dependency, and no `Setup.hs`. +- Legacy addresses are called `legacy` in the `derive` parameter, the default. + `normal`, the name they had, is still accepted, so old URLs keep working; + it said nothing about the kind of address. Error messages use the new + name. Built with haskoin-store-data at commit `b304acd2`. +- The executable gives memory back to the system as soon as its heap no + longer needs it (`--disable-delayed-os-memory-return` in its default RTS + options). By default GHC marks such memory free for the kernel to take when + it runs short, and Linux counts it as resident until then, so the heap of a + busy store seemed to grow without end, by the size of each peak, with little + live data. The stress test records the resident GHC heap and how much of it + is lazily freed. The heap profile and the runs that found this are in + `stress/results/2026-11-09-memory`, and `scripts/heap-profile-summary.py` + summarises a heap profile. +- The cache brings an entry up to date from what changed, instead of reading + the whole xpub from RocksDB and Redis on every change, which the stress test + showed was almost all the time of a reload, growing to seconds at 100,000 + transactions per xpub. A reload reads the changed transactions, the outputs + they create and spend at addresses of the xpub, and the balances of its + addresses, which are compared with Redis's to catch a change the entry + missed. The whole xpub is still read when it is first cached, when the + entry is more than a block behind, when an address with transactions enters + or leaves the gap, when a balance does not match, and every ten minutes. + Entries keep an index of their unspent outputs by outpoint + (`x::uop`), in format version 3; entries of version 2 are upgraded by + their next reload. New metric `cache.full_reloads`. +- A reload whose balances show changes it was not told of first looks for + them, instead of reading the whole xpub: the transactions that the database + has for the addresses whose balances moved, in the mempool or in blocks + after the one the entry was written at, and the mempool transactions of the + entry that have since been confirmed or dropped, up to 1,000. Under load the + database is often ahead of the events being applied, which made about one + reload in ten of the stress test a full one. +- Bodies that Redis already has, such as those of the transactions that a + block confirms, are rewritten before the commit of a reload, 200 to a + script, instead of in it. The commit of a block that confirms a thousand + transactions of an xpub had about 8,000 arguments and held Redis for 10 to + 30 ms, the only commands of the stress test that took that long. +- The scheduled full reload of a cached xpub comes every five to ten + minutes, an interval that depends on the xpub, instead of every ten for + all. Xpubs cached together were read whole together each time: in the full + stress test, four xpubs of tens of thousands of transactions raised the + heap from under 100 MiB to 785 MiB for a few seconds every ten minutes. +- `docs/cache-consistency.md` analyses how a cached xpub can differ from the + database without any check noticing, including spenders of cached + transactions that no reload repairs, and what would prevent it. +- `docs/layered-database.md`: a design for keeping the mempool out of the + chain's indices, in an area of its own that is applied on top when a query + is answered, with the measurements behind it and what it means for the + cache. The store still runs on the layout of version 20; this adds the + parts that could be proved ahead of the switch: + - `Haskoin.Store.Database.Types` has the keys of the mempool area + (`MemSpenderKey`, `MemAddrKey`, `MemDeletedKey`) and a marker for + migrations that work in several writes (`MigrationKey`). + - `Haskoin.Store.Database.Mempool` has the keys that one mempool + transaction contributes, and what the mempool does to the balance and + the unspent outputs of an address. + - `Haskoin.Store.Database.Migrate` moves a database of version 20 to the + layered layout without a resync: it takes every mempool transaction out + of the chain's indices and writes it to the mempool area, in atomic + batches that can be interrupted. Nothing calls it yet. + - `withLayeredReader` opens a database with the extra column family, + `mempool-addr`, that the layout needs. + - Tests build databases with the store's own rules from random histories + of payments, blocks, replacements, deletions and reorganisations, + migrate them, and check that every query answers as before, that the + chain's column families are those of a database that never saw a + mempool, and that emptying the mempool area leaves the chain's answers. +- `Haskoin.Store.Logic.Layered`: the rules that import and revert blocks + and add, replace and delete mempool transactions in the layered layout of + `docs/layered-database.md`, with the functions, results and errors of + `Haskoin.Store.Logic`. Blocks are written to the chain's column families + alone, and the mempool to its own area. The store does not use them yet. + - `Haskoin.Store.Database.Writer` can write the mempool area in the same + atomic batch as the chain; batches of today's rules write nothing there. + - Tests give the same random history to both sets of rules, on Bitcoin and + on Bitcoin Cash: payments, replacements, deletions, blocks in and out of + order, reorganisations, and transactions and blocks that must be + refused. Every operation must have the same result and move the same + transactions in and out of the mempool, every query must answer the same + after it, and at the end the database of today's rules, once migrated, + must equal that of the new rules key for key. + - One difference is on purpose: a block that spends an output of an + unconfirmed transaction is refused by the new rules, as that output is + not in the chain. Today it is imported. +- `Haskoin.Store.Database.Query.Layered`: every query of the store for the + layered layout, with the names and arguments of + `Haskoin.Store.Database.Query`, and `layeredRead`, which gives them as the + record of queries that the web server answers with. The store does not use + them yet. + - A query takes a `View`, a RocksDB snapshot that only `withView` makes, + so that the chain and the mempool are read as they were at one moment. + - Pages are cut from the mempool's part of a list followed by the chain's + part, by today's rules for starts, offsets and limits, for one address, + for several, and for extended public keys. + - Mempool spenders are looked up only for the outputs of a transaction + that no block spends, in one multi-get for a whole page of transactions. + - `MemDeletedKeyP` matches deleted transactions by the start of their + hash, for the short transaction numbers of the Blockchain.info API. + - Tests ask today's queries and the new ones for pages with random + limits, offsets and starts, on databases migrated from today's layout, + on databases built by the rules of the layered layout, and on databases + upgraded in the middle of a history. They also check that an open view + goes on answering from its moment while blocks and transactions are + written. +- A summary for each address that the mempool touches, in the layered + layout (`MemSummary`, under `MemAddrSumKey`): the number of its mempool + transactions, and the amounts and numbers of the outputs that the mempool + pays to it, spends, and both pays and spends. The measurements showed the + queries of that layout to be too slow for an address with much in the + mempool, and for any address right after a block, because they scanned + everything that the mempool has for an address to answer anything. + - A balance is now two reads by key, and an address with nothing in the + mempool is found by a key that is not there. + - Lists of transactions and of unspent outputs read the mempool's entries + only for addresses that have some, and only as far as the page goes. + - The rules keep the summary with every transaction that enters or leaves + the mempool, and the migration writes all of them from the entries that + it moved. The tests work every summary out again after each operation. + - Measured again with `QueryCost.hs`: the balance of an address with + 6,216 entries in the mempool takes 11 microseconds instead of 35 + milliseconds, a page of its transactions what it takes in version 20, + the balances of a wallet of 464 busy addresses 1.9 milliseconds instead + of 110, and nothing gets slower right after a block. Keeping the + summaries costs about 110 microseconds for each transaction that passes + through the mempool. `docs/layered-database.md` has the tables. +- `docs/layered-database/QueryCost.hs` writes one synthetic history into a + database of each layout and times the rules and the queries of both, + checking that the answers agree. `docs/layered-database.md` has the + results and what follows from them: writing costs the same when syncing + and 14% more for a transaction that passes through the mempool; the new + queries cost 10 to 15 microseconds more for a request when the mempool + has nothing for what is asked; and they are too slow, as built, for + addresses that the mempool touches a lot and for any address right after + a block. The document proposes a summary for each address in the mempool + area, read by key, and two changes to the RocksDB binding. +- Documentation: a page that starts at a height has no unconfirmed + transactions, whatever the height. The comment on `AtBlock` said that a + height above the best block includes them, and the API reference could be + read that way. The behaviour is unchanged. +- The stress report breaks the commands that blocked Redis down by script, + and commits by full and incremental reloads, with their numbers of + arguments. +- `Haskoin.Store.Fleet`: the rules by which stores that share a Redis agree + on one block to answer from, the fleet tip, as pure decisions with a model + test. It is the first part of the design for a fleet that answers as one, + in `docs/layered-database.md`. Nothing uses it yet. + `Haskoin.Store.Fleet.Redis` carries the rules out against Redis, with a + Lua script for each step that has to be one step, and a test that takes + random sequences of steps through a real Redis and through the rules and + compares them after each. `Haskoin.Store.Fleet.Pool` has the rules of the + mempool that such stores share, as of the fleet tip: what may be offered, + which of two conflicting transactions stays, what leaves and why, and how + the pool follows the tip forwards and across a reorganisation. A model + test keeps it valid on top of the tip through random offers, blocks and + reversals. One more Lua script carries these rules out, moving the tip and + changing the pool in one step, and is compared with them step by step in a + real Redis like the others; the comparison found a case that the rules had + left open, a transaction that comes back from an abandoned block and + spends what the pool already spends, which now wins. The pool also keeps, + for each address, what its transactions do there: the transactions and + the outputs paid to it in the order of a list, the outputs of it that are + spent, and their sums, so that a balance is one read and a list is read + by the page, as in a store's own mempool area. +- `Haskoin.Store.Database.Query.Pooled`: the queries of the store with a + mempool that is not its own on top of the chain, for the shared pool of a + fleet. `read.lua` and `poolRead` read that pool from Redis, each read + with a check that the fleet tip has not moved. The tests hold these + queries to those of the layered layout with the store's own mempool as + the pool. `fleetAdvance` can empty the pool for a store that is alone and + does not know the way from the old tip. +- `Haskoin.Store.Fleet.Member`: what a store does as a member of a fleet. + It keeps a view at each recent block, reports them, moves the fleet tip + with what the blocks in between did to the pool, offers its mempool, and + answers from the view at the tip with the pool on top. A test with a real + Redis takes a store that is alone in its fleet through random histories + and compares every answer with the store's own after each step. It found + that a body kept in the pool went stale when a parent was confirmed or + came back, because a transaction inherits from its unconfirmed parents + whether it can be replaced by fee; the pool now keeps that apart from the + body and corrects it as transactions come and go. +- `Haskoin.Store.Database.Views` keeps the database as it was at each recent + block, a RocksDB snapshot for each, so that a store can answer from the + block that its fleet agrees on and not only from its newest. Views that + are no longer needed are let go, and one that a request is reading is + released when the request is done. Nothing uses it yet. +- A store whose Redis does not answer goes on answering from its database, + instead of failing every request that the cache would have served. A + request waits at most two seconds for Redis; after that the store leaves + Redis alone until a health check finds it again. Meanwhile `/health` + answers 203, Non-Authoritative Information, with the header + `Haskoin-Degraded: redis`, when every other check passes: a status in the + 200s, so that load balancers keep the store, and not 200, so that + monitoring notices. The body of `/health` has a new check, `redis`, for a + store that has a cache; it does not count towards `ok`. It comes with + haskoin-store-data 1.9.0, which the store now takes from Hackage. +- Breaking: transactions that were deleted are no longer returned. A + transaction that was replaced, dropped from the mempool, or was the + coinbase of a block that left the main chain used to answer by id with + `"deleted": true`; clients that did not look at that field took it for a + pending payment. It now gives 404, is left out of lists of transactions + fetched by id, and a page cannot start at it. The `deleted` field stays in + responses and is always false. The bodies stay in the database. +- Breaking: parameters are checked. A request with a parameter that its + endpoint does not accept, such as a misspelt `limt=10` or `pretty` on the + Blockchain.info endpoints, which never honoured it, gives 400 + `Unknown parameter: …`; and a value that cannot be read, such as + `notx=yes`, `limit=-1`, `filter=4`, `format=xml` or an unknown currency, + gives 400 `Invalid value for parameter …`. Both used to be ignored, and + the client got an answer to a question it did not ask. Requests are + checked before anything is done. The Blockchain.info endpoints accept + `format=json`, which their clients often send. Each route of the router + declares the parameters it accepts, and reading an undeclared one is an + error of the program, so the two cannot drift apart. +- An xpub asked about with the wrong `derive` gives 400, with a message that + names the right kind, instead of an empty wallet: when the xpub has no + transactions with the kind asked for, the store checks the first + `--xpub-gap-init` addresses of the other kinds. This applies to the `/xpub` + endpoints and to `/blockchain/rawaddr`. A wallet unused with every kind + still gets an empty answer, and wallets in use cost nothing more. +- `swagger.yaml` explains the API, not only lists it: an introduction to its + conventions (amounts, ordering, paging, formats, errors, unconfirmed + transactions, reorganisations, xpubs, live events, Blockchain.info + compatibility) and the reasons for them, and a description of every + endpoint, parameter and field. It documents `/dbstats`, the WebSocket at + `/events` and the `time` field of the health check, which were missing, + and corrects the health check examples and the version. +- The README tutorial pages with `height`, the parameter the server reads; + it said `start`, which the server ignores. +- Every line of code is shorter than 120 columns, `swagger.yaml` included, + whose long hexadecimal and xpub examples are split into equal pieces that + parse to the same values. `scripts/format` formats `integration/` and + `stress/` too. +- Scripts live in files of their own: the Lua scripts of the cache in + `src/Haskoin/Store/Cache/lua/`, embedded at compile time with + `file-embed`; the script of wrk in `stress/wrk.lua`, one for every + endpoint, given its paths on the command line; and the shell steps of CI + in `scripts/check-local-deps.sh` and `scripts/install-system-libraries.sh`. + The scripts do the same as before. + +### Fixed + +- `--bloom` builds Bloom filters. It built none when the store was built + against RocksDB 6.24 or later, as the Docker image is, because + `rocksdb-haskell-jprupp` passed the size of the filter to RocksDB with the + wrong type. Nothing failed; a lookup of a key that is not there just went + on reading data blocks to find that out. The store is now built with + `rocksdb-haskell-jprupp` 2.6.3, which has the fix. A store that already + runs with `--bloom` starts building filters when it is upgraded, for the + table files written from then on: about 1.25 bytes for each key, held in + the block cache. Size that on a full database, or turn the option off to + keep things as they were. +- `--bloom` no longer asks for filters on the two indices by address, which + are scanned and not read by key. With a filter, a scan of an address that + has nothing steps over every key deleted since the last flush: 810 + microseconds after 5,000 mempool transactions were deleted, against 13 + without filters. No store was affected, because no filter was ever built; + with the fixed binding they would have been. The option still builds + filters for transactions, unspent outputs, blocks, balances and the + mempool. +- `/blockchain/multiaddr` no longer reads every transaction of the wallet to + count them. `n_tx` of one xpub is its count (a `ZCARD` when it is cached); + for several xpubs and addresses, the database counts the distinct + transactions of all their addresses from the keys of its index. The + transactions of a page are read in pages of about the size asked for, and + their bodies a page at a time, instead of one by one; `/blockchain/rawaddr` + does the same. In the stress test, with xpubs of about 15,000 + transactions, the median time of a multiaddr request went from 3.2 seconds + to 36 milliseconds, and it no longer grows with the wallet. +- Containers left by an integration test run that was killed are removed + by the next run, as intended: listing them used a template that Podman + refuses, so they were never found. +- `--peer HOST[:PORT]` works as documented. It was read as a Haskell + string, so only `--peer '"HOST:PORT"'`, with the quotes, was accepted. +- The syncing peer is disconnected when it sends a block that was not + requested, as the documentation of the block store said. The block was + imported if the node knew its header. The state of the block download is + now a pure state machine (`Haskoin.Store.BlockStore.Sync`) with property + tests, which also found that a block listed twice in one request was + outstanding twice. +- The block store no longer starts a thread for every transaction it + requests, to forget the request twenty seconds later. Requested and + received mempool transactions are one pure value + (`Haskoin.Store.BlockStore.Pending`), with property tests, and old + requests are forgotten on the clock tick of the block store. +- Build against haskoin-node 2.4.0, from the head of its + `fix-header-sync-stall` branch. The block store reserves its syncing peer + as an owner of its own (`reservePeer`, `releasePeer`), so no other part of + the node can release it; header searches run with `chainRunHeaders`. The + store stopped following the chain + when a peer announced new blocks with an inventory message instead of + headers, which peers do when many blocks are found at once; it stayed at + the old height until the peer reconnected. +- Mempool transactions that entered the mempool in the same second could be + listed twice in the transactions of an xpub or a multiaddr wallet, and + their order differed from page to page. Every merge now orders them as the + database and the cache store them (`txRefKey`, `unspentKey`). +- `nocache=true` on `/xpub/:xpub/transactions` and `/xpub/:xpub/unspent` no + longer reads, or fills, the cache. +- `confirmations` of `/blockchain/unspent` no longer wraps around for an + output in a block newer than the chain of the store. + +### Added + +- `scripts/stress-cache.sh`, a stress test of the Redis cache: a regtest + chain, Valkey and wrk in Podman, a haskoin-store server, hundreds of + thousands of transactions between a few wallets, and wrk on their xpubs + all the while, with a report (`scripts/stress-report.py`) of reloads, + lag, resources, the commands that blocked Redis (from its slow log) and + latencies, and a check of the cached answers at the end. The Podman + helpers of the integration tests are an internal library (`integration`) + that the stress program shares, and the test image has wrk in a layer of + its own. +- `stress/results/2026-11-09/`: the results of a full default stress run, + kept for comparison with later runs. +- `runWebSocket` serves the API on a socket that already listens. The tests + bind port 0 and pass the socket, so their web servers get free ports with + no window in which another program could take them; the containers publish + their ports on random ports of the host. +- Integration tests against regtest chains of Bitcoin Core and Bitcoin Cash + Node, with Valkey, in Podman containers built from Ubuntu 26.04 and + release tarballs checked against pinned hashes, one cached layer per + download, so nothing is downloaded twice. They are skipped when Podman + cannot run containers or `HASKOIN_STORE_NO_PODMAN` is set. + +## [1.8.1] - 2026-11-07 + +### Changed + +- Documentation: the README explains the purpose and design of the store, with + installation steps, a full configuration reference, monitoring and a + tutorial, and the Haddock of every module and function says why it works the + way it does. +- Build against nqe 0.6.9, rocksdb-haskell-jprupp 2.6.1, rocksdb-query 0.6.1, + statsd-rupp 0.5.0.2, secp256k1-haskell 2.0.1, haskoin-node 2.3.1 and + Stackage nightly-2026-11-07. + +## [1.8.0] - 2026-11-07 + +### Changed + +- Index the mempool by the time each transaction entered it. `/mempool`, + `/blockchain/unconfirmed-transactions` and the health check read only the + page they return, newest first, instead of loading and sorting the whole + mempool on every request. Data version 20: a version 18 or 19 database is + migrated when it is opened, with no resync. +- The block store no longer reads the whole mempool to publish mempool + events, to set the mempool gauge or to find expired transactions. Each + import reports which transactions it added to the mempool or removed from + it; pruning reads only the oldest entries of the index. Before, every + block, every batch of new transactions and every clock tick (several per + second) read the whole mempool at least once. +- Count the transactions of an xpub without building the list of all of them + when the cache is not used. +- Keep the derived addresses of the 512 to 1024 most recently queried xpubs + in memory. Every xpub query derived each address again before reading a + balance. Addresses depend only on the xpub, so the cache never goes stale. +- Page the unspent outputs of an xpub by merging its addresses in order of + block, stopping once the page is full, instead of decoding up to offset + plus limit outputs of every address and sorting them all. The pages are + the same. +- Count the transactions of an xpub by merging the raw keys of its + addresses, without decoding keys or reading values. +- Open the iterators of a query over many addresses in one bracket instead + of one bracket each. Every call into RocksDB walked the stack past one + frame per address. +- Double the page, up to 1024 rows, when streaming a source by offset, as + `/blockchain/unspent` does. The rows read and skipped grew with the square + of the rows returned. +- Check that an xpub is cached in the same Redis round trip as the read of + its balances, transaction count, or a page of its transactions or unspent + outputs that does not start at a transaction. +- Serialize a transaction at most twice to compute its id, size and weight, + and stop looking up its witnesses with a quadratic list index. +- Build on haskoin-core 1.6.1, which encodes CashAddr and Base58 addresses + faster: about 10% less CPU per request on endpoints that return many + addresses. +- The executable uses every core of the host by default (`-N` instead of + `-N4`). Set `+RTS -N -RTS` on the command line to choose a number. +- Read the balances of many addresses, and lists of transactions, with one + RocksDB multi-get instead of one read per key. `StoreReadBase` has a new + method, `getManyTxData`, which defaults to reading the transactions one by + one; `getTransactions` reads many transactions with it. +- Give RocksDB a block cache of 1 GiB by default, shared by all column + families, and keep their index and filter blocks in it at high priority, + with those of level 0 pinned. Before, each column family had RocksDB's + default cache of 32 MiB, and index and filter blocks stayed in memory + outside any cache for every open file. Set the size with `--block-cache-mb` + or `BLOCK_CACHE_MB`; 0 restores the RocksDB defaults. `StoreConfig` and + `withDatabaseReader` take the size in bytes. Requires rocksdb-haskell-jprupp + 2.6.0. + +### Added + +- `store/bench`: a benchmark server that syncs a synthetic regtest chain and + serves the web API on it, and times the encoding of a response with the + argument `micro`. `scripts/bench-web.sh` runs wrk against it and reports + the CPU time of the server per request. + +## [1.7.0] - 2026-11-06 + +### Changed + +- Build on haskoin-core 1.6.0 and haskoin-node 2.3.0, the releases with the + fixes of the November 2026 security review. Their changelogs list the + changes to message parsing, header validation and peer handling that the + store now runs with. +- An output has an address only when the network defines one for its script, + as in haskoin-core 1.6.0. A SegWit-shaped output has no address on Bitcoin + Cash. A 256-bit script hash output (`OP_HASH256`, a push of 32 bytes, + `OP_EQUAL`) has none on Bitcoin. Such an output is no longer indexed under + an address, and its `address` is `null`. Entries that an older version + wrote under such an address stay in the database. No request can name them, + since the address has no text form on the network. +- `POST /transactions` takes a body that holds one transaction and nothing + else. Bytes after the transaction are refused, as Bitcoin Core does for a + raw transaction. They used to be ignored. +- `POST /transactions` takes the transaction in the format that peers of the + network read. A network without SegWit, such as Bitcoin Cash, has the + format without witness only. +- `GET /peers` gives the `version` of a peer as a signed number, as + haskoin-core 1.6.0 reads it. A peer that sends version ffffffff has version + -1, where it used to appear as 4294967295. +- Breaking, in `haskoin-store-data`: `toTransaction` takes the `Network` as + its first argument, and the `version` field of `PeerInfo` is an `Int32`. + The binary form of `PeerInfo` is the same bytes as before. +- From haskoin-node 2.3.0: a peer is disconnected when it sends more than + 50000 entries in an `inv` or `getdata` message. On Bitcoin Cash a message + may be at most 2 MiB, unless it carries block content. Transactions from + Bitcoin Cash peers are read in the format without witness only. + +### Fixed + +- A response no longer fails on a transaction with an output that has no + address on the network. Since haskoin-core 1.5.0 the JSON encoder of such + an address threw, which cut the response off. One such output is in Bitcoin + block 211997 (transaction + `a4bfa8ab6435ae5f25dae9d89e4eb67dfa94283ca751f393c1ddc5a837bbc31b`, + output 0). + +## [1.6.5] - 2026-11-04 + +### Fixed + +- Build on haskoin-core 1.5.1, which evaluates the ASERT difficulty rule at the + parent block. With 1.5.0 the store rejected a valid block on Bitcoin Cash + mainnet at height 975899. + +## [1.6.4] - 2026-11-04 + +### Added + +- Support Bitcoin testnet4 (`NET=btctest4`), from haskoin-core 1.4.0. +- Option `--block-window` (`BLOCK_WINDOW`) to set how many blocks to request + from the syncing peer at a time. +- Option `--write-buffer-mb` (`WRITE_BUFFER_MB`) to cap RocksDB memtables + across all column families, 256 MiB by default (0 = unlimited). Without a + cap the nine column families can keep up to 1.1 GiB of memtables. +- Option `--max-wal-mb` (`MAX_WAL_MB`), 1024 MiB by default (0 = RocksDB + default), to bound the RocksDB write-ahead log: once it is larger, the + column families holding its oldest file are flushed so the file can be + deleted. +- `/dbstats` starts with the memory RocksDB uses outside the GHC heap: + memtables and table readers for each column family, and the block cache. +- The mempool is kept in its own column family, one key per transaction, + instead of as a single list value that every import batch read, loaded + into a hash table and wrote back whole. Data version 19: a version 18 + database is migrated when it is opened, with no resync. + +### Changed + +- Replace monad-logger with the fast-logger `Logger` from haskoin-node 2.0.0. +- Request 64 blocks at a time from the syncing peer instead of 500, and ask + for more once fewer than 16 remain, to bound memory use while catching up. +- haskoin-store-data builds against secp256k1-haskell 2.0.0, which hides the + raw `PubKey` constructor: `XPubSpec` reads its stored key with `pubKey`, + which checks it. +- Build on haskoin-core 1.5.0, haskoin-node 2.1.2 and secp256k1-haskell 2.0.0. + `genesisBlock` no longer takes a context. +- A pay-to-public-key output has no address any more, as in haskoin-core + 1.5.0. Its coins cannot be spent with the input script of the P2PKH address + of the same key, so they are no longer counted under that address. +- The block store no longer reads the whole mempool four extra times on every + internal ping: it compares mempool snapshots only when there are pending + transactions to import or expired ones to delete. +- Run with four capabilities (`-N4`) instead of one per core (`-N`), so that + memory overhead does not grow with the size of the host. Override with + `+RTS -N -RTS`. +- Docker image: pin the base image to Debian trixie (RocksDB 9.10) by digest + instead of `debian:latest`, and run with `MALLOC_ARENA_MAX=2` to limit + malloc fragmentation from RocksDB. +- Each `/events` client, websocket or HTTP stream, gets a queue of at most + 10,000 events and is disconnected when it fills up, instead of the queue + growing for as long as the client stays connected. Store events that + `/events` does not show are no longer queued for its clients. +- A request waiting for another to load an xpub into the cache retries for + about 30 seconds, with at most 5 seconds between attempts, and then serves + the xpub from the database. It used to retry forever with a delay that + doubled each time. + +- Continuous integration on GitHub Actions: build, run both test suites, + and check that the heap stays flat while syncing 6000 regtest blocks. + +### Fixed + +- Support full-RBF: accept replacements of transactions that do not signal BIP125. +- Correct various space leaks. +- `Unspent` implements `coinInputKind`, new in haskoin-core 1.5.0, from its + output script, so coin selection with it no longer fails at run time. + +### Added + +- Support for testnet4 on both networks. + +## [1.6.3] - 2026-08-31 + +### Added + +- Allow disabling web server to sync block chain only. + +## [1.6.2] - 2026-08-13 + +### Fixed + +- Fix upstream regressions in haskoin-node. + +## [1.6.1] - 2026-08-13 + +### Fixed + +- Support latest version of haskoin-node. + +## [1.6.0] - 2026-08-12 + +### Fixed + +- Support for Bitcoin Cash 256-bit scripts. +- Address parsing now allows only correct lengths. + +## [1.5.16] - 2025-05-08 + +### Changed + +- Move to personal repository. + +### Removed + +- Disable `NO_SLOW` as an option. + +### Added + +- Allow to set `NO_XPUB` to disable extended public keys. + +## [1.5.14] - 2024-12-04 + +### Changed + +- Move `/dbstats` and `/mempool` to slow endpoints section. + +### Added + +- Cull old transactions from mempool automatically. + +## [1.5.13] - 2024-10-25 + +### Changed + +- Dummy release: update upstream LTS Haskell dependency in `stack.yaml` file. + +## [1.5.12] - 2024-07-22 + +### Added + +- Metric to track time to import a new block. +- Parameter `no_compact` allowed for backwards compatiblity. + +## [1.5.11] - 2024-05-24 + +### Fixed + +- Parameter `noCompact` corrected for `multiaddr` endpoint. + +## [1.5.10] - 2024-05-24 + +### Fixed + +- Prune obsolete transactions from outgoing peer requests. +- Remove unnecessary module imports. + +## [1.5.9] - 2024-05-23 + +### Fixed + +- Only sync mempool once for each peer. + +## [1.5.8] - 2024-05-23 + +### Fixed + +- Dummy release to bump upstream dependency on `haskoin-node`. + +## [1.5.7] - 2024-05-23 + +### Fixed + +- Dummy release to bump upstream dependency on `statsd-rupp`. + +## [1.5.6] - 2024-05-22 + +### Changed + +- Allow to toggle RocksDB Bloom filters off. + +### Fixed + +- Correct command-line option behaviour for some rarely-used parametres. + +## [1.5.5] - 2024-05-19 + +### Changed + +- Lock Redis before checking if the database needs to be pruned, rather than after. +- Lock xpub in Redis to avoid computing derivations multiple times. + +### Fixed + +- Rename redis-min-gap to redis-min-addrs to match environment config variable. + +## [1.5.4] - 2024-05-07 + +### Fixed + +- Fix Redis bug where old keys weren't pruned quickly enough. + +### Changed + +- Remove Nomad-specific environment variable parsing for statsd. + +## [1.5.2] - 2024-04-24 + +### Changed + +- Use default GHC garbage collector. + +## [1.5.1] - 2024-04-23 + +### Changed + +- Compile with GHC 9.8.2. +- Enable optimisations. + +## [1.5.0] - 2024-04-06 + +### Fixed + +- Use an optimised topological sort for importing transactions in bulk. + +## [1.4.0] - 2024-03-27 + +### Changed + +- Use default optimisation settings. +- Use default RocksDB parameters. + +## [1.3.0] - 2024-03-14 + +### Changed + +- Bump upstream dependencies. + +## [1.2.5] - 2023-01-31 + +### Fixed + +- Test suite now working again. + +## [1.2.4] - 2023-01-31 + +### Changed + +- Bump upstream dependencies. + +## [1.2.3] - 2023-12-06 + +### Changed + +- Transactions received via POST are just forwarded to every peer without delay or validation. +- Bump dependency on NQE to resolve async issue. + +## [1.2.2] - 2023-10-21 + +### Fixed + +- Fix comparison function for unspent outputs. + +### Changed + +- Avoid deprecated `param` function from Scotty. + +## [1.2.1] - 2023-10-04 + +### Fixed + +- Correct web exception output format (JSON). +- Correct block path parsing order. + +## [1.2.0] - 2023-10-03 + +### Changed + +- Upgrade `scotty` dependency and fix incompatibilities. + +## [1.1.0] - 2023-09-15 + +### Added + +- Add cache height stats. +- Add database iterator stats. + +### Changed + +- Detect xpub gap more strictly. +- Use statsd-rupp instead of ekg-stats. +- All stat reporting keys changed. + +### Removed + +- Remove unsafeInterleaveIO from Web.hs. +- Remove unnecessary WAI middlewares. +- Remove server and client error reporting per endpoint. + +## [1.0.2] - 2023-08-25 + +### Changed + +- Code refactoring and simplification. +- Improve logging output. + +### Removed + +- Do not impose time limits on REST API responses. + +### Fixed + +- Remove loop in Blockchain.info unspents function. +- Correct documentation for /blockchain/rawblock endpoint. +- Fix no match in record selector address for coinbases. + +## [1.0.1] - 2023-08-03 + +### Changed + +- Add compatibility with latest nightly LTS Haskell. + +## [1.0.0] - 2023-07-28 + +### Changed + +- Compatibility with latest haskoin-core and haskoin-node packages. +- Use DuplicateRecordFields and OverloadedRecordDot language extensions. +- Modernize package in a backwards-incompatible manner. +- Refactor package extensively. + +## [0.65.10] - 2023-05-12 + +### Changed + +- Revert to older LTS Haskell to attempt to resolve memory leak. + +### Removed + +- Remove unnecessary lock release. + +## [0.65.9] - 2023-05-09 + +### Changed + +- Be more aggressive caching individual transactions. +- Introduce a periodic cache mempool sync task. + +## [0.65.8] - 2023-05-08 + +### Changed + +- Perform health check in separate thread. + +## [0.65.7] - 2023-05-05 + +### Changed + +- Do not sync mempool to Redis if node is not up-to-date. + +## [0.65.6] - 2023-05-04 + +### Changed + +- Improve caching ingestion performance. + +## [0.65.5] - 2022-09-19 + +### Added + +- Fee field added to Blockchain.info-style export-history endpoint. + +### Changed + +- Bump version due to Git mistake. + +## [0.65.3] - 2022-04-13 + +### Added + +- IPv6 peer support. + +## [0.65.2] - 2022-04-13 + +### Fixed + +- Correct lazy bytestring deserialization algorithm for web client. + +## [0.65.1] - 2022-04-13 + +### Changed + +- Simplify function in Cache module. +- Bump depenedencies. + +## [0.65.0] - 2022-02-03 + +### Changed + +- Spenders now embedded into tx objects in database for performance. +- Use faster IORef instead of slow TVar when ingesting. +- Use mutable hash tables when ingesting. +- Allow to disable unscalable API endpoints. + +## [0.64.19] - 2022-02-01 + +### Added + +- Allow to set query timeouts. + +## [0.64.18] - 2022-01-21 + +### Fixed + +- Off-by-one error when importing change addresses to cache. + +## [0.64.17] - 2022-01-21 + +### Fixed + +- Add change addresses to cache when necessary. + +## [0.64.16] - 2022-01-10 + +### Fixed + +- Correct fee calculation for blocks that do not claim all rewards. + +## [0.64.15] - 2022-01-07 + +### Fixed + +- Correct scale of cache pruning code. + +## [0.64.14] - 2022-01-07 + +### Fixed + +- Always prune to 80% of max cache size. + +## [0.64.13] - 2022-01-07 + +### Fixed + +- Avoid doing a hissy fit on transient cache issue. + +## [0.64.12] - 2022-01-07 + +### Fixed + +- Prune a little more cache to allow for new keys. + +## [0.64.11] - 2022-01-06 + +### Fixed + +- Prune cache more often. + +## [0.64.10] - 2021-12-30 + +### Changed + +- Return empty addresses in xpub balances call. + +## [0.64.9] - 2021-12-29 + +### Fixed + +- Avoid notifying same transactions in mempool. + +## [0.64.8] - 2021-12-26 + +### Changed + +- Use better Fourmolu format. +- Be more precise when counting retrieved items. + +### Fixed + +- Avoid transactions duplicated in xpub data. +- Refactor some functions to make them more robust. + +## [0.64.7] - 2021-12-26 + +### Fixed + +- Optimisations for various Blockchain endpoints. +- More accurate item counts for various web endpoints. + +## [0.64.6] - 2021-12-25 + +### Fixed + +- Record cache index time just once per xpub. + +## [0.64.5] - 2021-12-25 + +### Changed + +- Add suffix cached to cache entries to avoid conflicts with data entries. + +## [0.64.4] - 2021-12-25 + +### Fixed +- Bring dots back and avoid stats hacks. + +## [0.64.3] - 2021-12-25 + +### Fixed + +- Fix typo. + +## [0.64.2] - 2021-12-25 + +### Changed + +- Replace dots for underscores in metrics. + +## [0.64.1] - 2021-12-25 + +### Changed + +- Automatic formatting. +- Improve cache debug logging. + +### Fixed + +- Add item count to 'all' query metrics. + +## [0.64.0] - 2021-12-25 + +### Changed + +- Improve metrics. + +### Fixed + +- Get lock before importing transactions to cache. + +## 0.63.0 +### Fixed +- Make cache updates lightweight. + +## 0.62.1 +### Fixed +- Fix idempotent transaction elimination bug. + +## 0.62.0 +### Added +- Configurable Blockchain price URLs. +- Reuse HTTP connections with wreq sessions. + +## 0.61.1 +### Changed +- Upstream improvements on Base58 performance. + +## 0.61.0 +### Fixed +- Fixed recursion bug in Blockchain format conversion function. + +## 0.60.0 +### Fixed +- Correct notifications subsystem. + +## 0.59.0 +### Fixed +- Correct internal dependency. + +## 0.58.0 +### Fixed +- Correct output freeing algorithm. + +## 0.57.0 +### Changed +- Report errors freeing outputs. + +## 0.56.0 +### Changed +- Report all deleted mempool transactions. +- Crash on certain data corruption. + +## 0.55.0 +### Changed +- Always have a previous output object in Blockchain inputs. + +## 0.54.0 +### Added +- WebSocket support. +- Testnet4 support. + +## 0.53.11 +### Changed +- Dummy version increase to signal upstream update of Haskoin Core. + +## 0.53.10 +### Fixed +- Correct test that was reversed in previous version. + +## 0.53.9 +### Removed +- Mempool is no longer synced by default to fix public Bitcoin Core regression. + +## 0.53.8 +### Changed +- Put derivations stat inside database. + +## 0.53.7 +### Added +- Added counters for database retrievals. +- Added counter for xpub derivations. + +### Changed +- Removed some buggy or unnecessary stats. + +## 0.53.6 +### Changed +- Improve web server statistics. + +## 0.53.5 +### Addded +- Endpoint to delete an xpub from cache. + +## 0.53.4 +### Added +- Debugging when reverting block. + +### Fixed +- Negative (headers - blocks) diff shown incorrectly. +- Infinite loop when removing a block's coinbase transaction. + +## 0.53.3 +### Added +- Blockchain.info endpoint: `q/pubkeyhash/:addr`. +- Blockchain.info endpoint: `q/getsentbyaddress/:addr`. +- Blockchain.info endpoint: `q/pubkeyaddr/:addr`. +- Configurable request body limit size. + +## 0.53.2 +### Fixed +- Return output in satoshi for some endpoints. + +## 0.53.1 +### Fixed +- Return 404 in case of bad address. + +## 0.53.0 +### Added +- Blockchain.info endpoint: `q/addresstohash/:addr`. +- Blockchain.info endpoint: `q/addrpubkey/:pubkey`. +- Blockchain.info endpoint: `q/hashpubkey/:pubkey`. +- Blockchain.info endpoint: `q/getblockcount`. +- Blockchain.info endpoint: `q/latesthash`. +- Blockchain.info endpoint: `q/bcperblock`. +- Blockchain.info endpoint: `q/txtotalbtcoutput/:txid`. +- Blockchain.info endpoint: `q/txtotalbtcinput/:txid`. +- Blockchain.info endpoint: `q/txfee/:txid`. +- Blockchain.info endpoint: `q/txresult/:txhash/:addr`. +- Blockchain.info endpoint: `q/getreceivedbyaddress/:addr`. +- Blockchain.info endpoint: `q/addressbalance/:addr`. +- Blockchain.info endpoint: `q/addressfirstseen/:addr`. +- Support xpubs in `blockchain/rawaddr` endpoint. + +### Fixed +- Various latest blocks endpoint fixes. +- Allow empty parameters in Blockchain.info POST requests. + +## 0.52.13 +### Fixed +- Upstream fixes for unknown inv types. + +## 0.52.12 +### Fixed +- Fix limits for legacy endpoints. + +## 0.52.11 +### Added +- Alias for Blockchain.info raw address endpoint. + +### Fixed +- Fix unknown message types without payload upstream. +- Randomise peer timeouts upstream. + +## 0.52.10 +### Fixed +- Fix binary search algorithm for blocks upstream. + +## 0.52.9 +### Added +- Add Blockchain.info latest block endpoint. +- Add Blockchain.info unconfirmed-transactions endpoint. +- Add Blockchain.info blocks for one day endpoint. + +## 0.52.8 +### Fixed +- Fix special case for zero limit. + +## 0.52.7 +### Fixed +- Fix cache bug when too many transactions in mempool. + +## 0.52.6 +### Changed +- Use rationals for Blockchain.info export-history endpoint arithmetics. + +## 0.52.5 +### Added +- Support for Blockchain.info export-history endpoint. + +### Fixed +- Use strict bytestring decoder for HTTP API client. + +## 0.52.4 +### Fixed +- Use Base58 addresses by default in Blockchain.info balance querios. + +## 0.52.3 +### Fixed +- Errors should also contain CORS headers. + +## 0.52.2 +### Fixed +- Blockchain.info raw address limit should use `limit` parametre and not `n`. + +## 0.52.1 +### Changed +- Stream multiple transactions when requested. + +### Fixed +- Fix missing unspent outputs. + +## 0.52.0 +### Changed +- Remove unnecessary performance optimisations. + +### Fixed +- Reduce balance retrievals for xpubs. +- Hack UTXO ordering to avoid unwanted behaviours. +- Do not merge conduits when there are too many. + +## 0.51.0 +### Fixed +- Data type for RequestTooLarge was missing. + +## 0.50.3 +### Added +- Log HTTP request bodies. + +### Removed +- Remove web request timeout. + +### Fixed +- Do not ignore unknown start tx anchors in conduits. +- Use fast transaction counting in cache. + +### Changed +- Use WAI middlewares to manage stats. + +## 0.50.2 +### Fixed +- Do not use lazy parsers for incoming data that may throw exceptions. + +## 0.50.1 +### Fixed +- Do not allow incoming POST requests of unlimited body size. + +## 0.50.0 +### Added +- Limit number of simultaneous xpubs being cached. + +## 0.49.0 +### Changed +- Improve conduit merging algorithm. + +## 0.48.0 +### Added +- Timeouts and token bucket for web requests. +- Configurable price fetch interval. + +## 0.47.6 +### Fixed +- Fix web.all stat. + +## 0.47.5 +### Changed +- Simplify stats. + +## 0.47.4 +### Added +- Implement Blockchain.info block height. +- Implement Blockchain.info raw address. +- Implement Blockchain.info balances. + +### Fixed +- Make Blockchain.info unspent endpoint more efficient. +- Make Blockchain.info xpubs endpoint more efficient. + +### Changed +- Use compact JSON serialization by default everywhere. + +## 0.47.3 +### Fixed +- Fix serialization bug with unspents. + +## 0.47.2 +### Fixed +- Fix serialization bug for health check. + +## 0.47.1 +### Fixed +- Fix serialization bugs for web data types. + +## 0.47.0 +### Added +- Support for legacy block endpoints. + +### Changed +- Serialization now uses bytes library and does interleaved IO. + +## 0.46.6 +### Added +- Allow comma-separated values in multiaddr. + +## 0.46.5 +### Changed +- Throw error when offset exceeded instead of truncating it. + +## 0.46.4 +### Fixed +- Do not compute balances separately for loose addresses when part of an xpub. + +### Changed +- Do not fetch entire transaction list for loose addresses. +- Transaction count in wallet object is just a synonym for filtered tx count. +- Use conduits to prevent over-fetching transactions from database. + +## 0.46.3 +### Fixed +- Make hex value encoding compatible with Java BigInteger decoder. + +## 0.46.2 +### Changed +- Allow negative confirmations for compatibility with old API. + +## 0.46.1 +### Added +- Filters for transactions in multiaddr endpoint. + +## 0.46.0 +### Fixed +- Release to fix unintentional upload. + +## 0.45.0 +### Added +- Using a tx_index that results in a txid conflict returns a 409 - Conflict. + +## 0.44.0 +### Changed +- Numeric txid now 53 bits long and doesn't return transactions when hashes collide. + +## 0.43.1 +### Fixed +- Do not overcount statistics. + +## 0.43.0 +### Changed +- Transaction index now simply encodes txid as a long number (sorry JS users). + +## 0.42.4 +### Changed +- Optimise encoding of JSON data for Blockchain.info API. + +## 0.42.3 +### Changed +- Narrow down the balance for transactions to onlyShow set. + +## 0.42.2 +### Changed +- Make unspent algorithm more efficient. + +## 0.42.1 +### Added +- Support for Blockchain.info API unspent endpoint. + +### Fixed +- Fix RBF transactions on Blockchain.info API. + +## 0.42.0 +### Removed +- No more pruning of old mempool transactions. + +## 0.41.4 +### Fixed +- Correct error computing wallet balances. + +## 0.41.3 +### Changed +- Use whole active set when computing results for multiaddr. +- Compute correct count of transactions for wallet. + +## 0.41.2 +### Changed +- Caching mempool is not much slower when pruning, so reversing that change. + +## 0.41.1 +### Changed +- Only prune mempool every ten minutes or so. + +## 0.41.0 +### Removed +- No more cache eviction endpoint. + +## 0.40.22 +### Added +- More metrics for cache. + +## 0.40.21 +### Added +- Support HTTP GET for multiaddr endpoint. + +## 0.40.20 +### Added +- Prefix 'app.' in statsd when using Nomad variables. + +## 0.40.19 +### Added +- Statsd support and pleny of statistics. + +### Removed +- Removed use of sync lock for importing xpubs in cache due to volume. + +## 0.40.18 +### Added +- New options to control cache lock retry count and delay. + +### Changed +- Cache xpubs asyncrhonously. +- Mempool syncs fully every refresh cycle. + +## 0.40.17 +### Changed +- Delete more than 1000 xpubs from Redis if needed. +- Attempt to get lock ten times in order to index a new xpub. + +## 0.40.16 +### Fixed +- Fix best block not set. + +## 0.40.15 +### Fixed +- Do not update cache best block if it is higher. + +## 0.40.14 +### Fixed +- Always respond to cache pings to avoid getting stuck. + +## 0.40.13 +### Added +- Be more careful about importing blocks to the cache. + +### Removed +- Reduce excessive cache logging. + +## 0.40.12 +### Fixed +- Correct bad arithmetics in cache cooldown. + +## 0.40.11 +### Added +- Debug log cache cooldown. + +### Fixed +- Unlimited retry lock acquisition now works. +- Make locking tighter + +## 0.40.10 +### Changed +- Reduce the number of things that cache do when pinged. + +## 0.40.9 +### Fixed +- Avoid filling the cache actor mailbox with pings. + +## 0.40.8 +### Fixed +- Correct a typo in cache code. + +## 0.40.7 +### Changed +- Improve cache mempool sync algorithm. + +## 0.40.6 +### Changed +- Make cache cooldown a number. + +## 0.40.5 +### Added +- Log every non-successful query. + +## 0.40.4 +### Fixed +- Use Redis TTL for cache cooldown. + +## 0.40.3 +### Fixed +- Mempool no longer gets saved in cache when node is not in sync. + +## 0.40.2 +### Changed +- Change source of price data to https://blockchain.info/ticker. + +## 0.40.1 +### Removed +- Do not expose Paths_haskoin_store module explicitly. + +## 0.40.0 +### Added +- Blockchain.info API compatibility for multiaddr and rawtx endpoints. + +### Changed +- Segwit fields are no longer omitted on incompatible networks. + +## 0.39.0 +### Changed +- Upgrade Haskoin Core to support higher version on witness addresses. + +## 0.38.4 +### Fixed +- Fix block search by timestamp. + +## 0.38.3 +### Changed +- Disable low latency garbage collector by default. + +## 0.38.2 +### Changed +- Use GHC 8.10 and its low latency garbage collector. + +## 0.38.1 +### Changed +- Optimise algorithm for fork safety check. + +## 0.38.0 +### Added +- Support for Bitcoin Cash hard fork. + +## 0.37.5 +### Added +- Configurable cache refresh time. + +## 0.37.4 +### Fixed +- Now request mempool when connecting even if already in sync. + +### Changed +- Add a delay to mempool sync to allow for block headers to catch up. +- Attempt to sync mempool whenever syncing is done or a new peer connects. + +## 0.37.3 +### Changed +- Correct logic error when deleting superseded transactions. + +## 0.37.2 +### Changed +- Simplify multiple algorithms to hopefully solve corruption bug. +- Allow to disable mempool transaction indexing via command line. + +## 0.37.1 +### Changed +- Better locking around caching operations. +- Have a global cooldown on cache mempool updates. + +### Fixed +- Fix address unspent retrieval using correct column family. + +## 0.37.0 +### Added +- Add support for column families and prefixes breaking database backwards compatibility. + +## 0.36.2 +### Fixed +- Fix another place where mempool sorting was wrong. + +## 0.36.1 +### Fixed +- Fix wrong sorting of mempool transactions in database. + +## 0.36.0 +### Changed +- Do not use STM transactions because it is impossible to reason about preloading. +- Make importing blocks after mempool is populated faster. + +## 0.35.2 +### Changed +- Reduce frequency of cache mempool updates. + +## 0.35.1 +### Changed +- Remove cache lock retries. +- Do not use lock when caching a new xpub. + +## 0.35.0 +### Changed +- Use new RocksDB Haskell bindings. +- Make headers - blocks diff configurable in health check. +- Simplify locking in cache. + +## 0.34.8 +### Changed +- Minor refactoring. +- Only send one mempool message ever. + +## 0.34.7 +### Changed +- Fix block heights endpoint URL. + +## 0.34.6 +### Removed +- Remove asynchronous database retrieval permanently due to instability. + +## 0.34.5 +### Added +- Preload memory before freeing outputs. + +## 0.34.4 +### Added +- Asynchronous preloading only for blocks. + +## 0.34.3 +### Removed +- Disable asynchronous preloading to prevent segmentation fault error. + +## 0.34.2 +### Removed +- No more upper limit for mempool call. + +### Fixed +- Health check uses minimum between last block and mempool tx. + +## 0.34.1 +### Added +- Pending mempool transactions health check. + +### Removed +- No more upper limit for mempool call. + +## 0.34.0 +### Changed +- New format for health check. + +## 0.33.1 +### Changed +- Upload with updated Cabal files. + +## 0.33.0 +### Fixed +- Fix outputs showing up as both spent and unspent. + +### Changed +- Simplify data structures used to hold uncommitted changes. +- Split StoreRead class in two. +- Improve pre-loading algorithms. + +## 0.32.3 +### Fixed +- Fix command line argument mappings to env vars. + +## 0.32.2 +### Fixed +- Do not complain when deleting non-existent unconfirmed txs. + +## 0.32.1 +### Fixed +- Fix corruption bug when deleting transactions during some reorgs. +- Fix tests on data package. +- Rename upstream address string functions. + +## 0.32.0 +### Changed +- Concurrently load dependencies when importing transaction data. +- Import each transaction using STM. +- Rework logging. +- Refactor all block chain importing algorithms. +- Use peer locking when importing data. +- Change license to MIT. + +### Added +- Make max peer count configurable. + +### Fixed +- Prevent premature peer timeouts when importing blocks. + +## 0.31.0 +### Added +- Add Haskell web client code to data library. +- Use type-safe definitions for web paths and parameters. +- Support JSON pretty encoding and enable by default for some endpoints. +- Allow environment variables for configuration. + +### Changed +- Change command-line arguments to better fit GNU style. +- Refactor code to manipulate address balances. +- Improve logging. +- Rate-limit mempool importing. +- Do not add xpubs to cache if node not in sync. +- Do not import transactions to cache if no xpubs in cache. +- Refactor transaction importing logic extremely. +- Refactor memory database and writer. + +### Fixed +- Fix BTC double-count transaction bug. +- Add missing xpub derive parameter to xpub evict documentation. + +## 0.30.1 +### Changed +- Limit mempool API endpoint list. + +## 0.30.0 +### Changed +- Raw JSON values are now wrapped in an object with a result property. +- Better logging when importing transactions into mempool. + +### Fixed +- Transaction limit by block height works now. + +## 0.29.3 +### Changed +- Revert concurrent retrieval changes from 0.29.1 and 0.29.0 to solve stability + issues. +- Bitcoin Cash (BCH) replaces BTC as default network in CLI. +- Peer discovery enabled automatically if no peers specified in CLI. +- Use separate Stack configuration file for data package. + +## 0.29.2 +### Changed +- Increase timeouts for manager and chain health checks. + +## 0.29.1 +### Added +- Perform xpub operations concurrently. + +## 0.29.0 +### Changed +- BlockTx renamed to TxRef. +- Remove unnecessary monad transformers to simplify import code. + +### Added +- Retrieve balances and unspent outputs concurrently when importing. +- Coin instance for Unspent in data package. + +## 0.28.0 +### Changed +- Change the way that limits, start, and offset values are handled. + +### Fixed +- Fix incorrect limit responses. + +## 0.27.0 +### Added +- Complete support for offset. + +### Changed +- Improve monad stack for cache. + +## 0.26.6 +### Added +- Support for offset in all endpoints where it makes sense. + +## 0.26.5 +### Fixed +- Sort after using the nub function or use Data.List.nub in exceptional cases. + +## 0.26.4 +### Changed +- Don't do certain validity checks on confirmed transactions. + +### Fixed +- Do not crash when syncing the blockchain from scratch on a populated cache. + +## 0.26.3 +### Changed +- Replace nub function everywhere with faster version written using hash sets. + +### Fixed +- Fix shared cache locking. + +## 0.26.2 +### Changed +- Simplify cache block import code. +- Improve cache import performance. + +## 0.26.1 +### Fixed +- Do not call zadd or zrem in Redis with incorrect argument count. + +### Changed +- Do not use slow Transaction type in Logic. +- Improve logging while importing blocks. +- Better transaction import algorithm. + +## 0.26.0 +### Changed +- Add information to some binary types for feature parity with JSON. + +## 0.25.4 +### Changed +- Hide segwit data on non-segwit networks. + +### Fixed +- Fix work which now always serialises as a number literal. + +## 0.25.3 +### Changed +- Fix version display on health check. + +## 0.25.2 +### Changed +- Fix wrong version of Haskoin Store Data dependency. + +## 0.25.1 +### Changed +- Improve code organisation. +- Split data definitions and serialisation into its own package. + +## 0.24.0 +### Changed +- Use mocking to simulate peers instead of connecting to the network while testing. +- Depend on latest version of Haskoin Core for faster JSON serialisation. +- Clean up confusing JSON encoding/decoding codebase. + +## 0.23.24 +### Changed +- Implement faster JSON encoding using toEncoding from the Aeson library. + +## 0.23.23 +### Changed +- Do not read full mempool so often from cache code. + +## 0.23.22 +### Changed +- Depend on latest Haskoin Node that fixes debugging regression. + +## 0.23.21 +### Changed +- Reduce non-debug log verbosity. + +## 0.23.20 +### Changed +- Better Haskoin Node logging. + +## 0.23.19 +### Changed +- Use set peer timeout instead of constant in block store. + +## 0.23.18 +### Changed +- Allow setting peer timeouts in command line. + +### Fixed +- Bump Haskoin Node dependency to fix another premature timeout condition. + +## 0.23.17 +### Fixed +- Touch syncing peer whenever we process one of its blocks to avoid premature timeout. + +## 0.23.16 +### Changed +- Better algorithm to avoid importing transaction multiple times in cache. +- Depend on latest Haskoin Node. + +## 0.23.15 +### Changed +- Do not storm the cache with mempool transactions. + +## 0.23.13 +### Fixed +- Do not ignore deleted incoming transactions. + +## 0.23.12 +### Fixed +- Do not do RBF checks when replacing a mempool transaction with a confirmed one. + +## 0.23.11 +### Fixed +- Streamline mempool transaction importing. + +## 0.23.10 +### Fixed +- Fix transactions not recorded in cache mempool set. +- Fix transactions being downloaded multiple times. + +### Removed +- Do not store orphan transactions in database. + +### Changed +- Use sets for incoming transactions instead of lists. +- Do not do anything to the cache if there are no xpubs in it. + +## 0.23.9 +### Fixed +- Wiping mempool fixed. + +## 0.23.8 +### Added +- Chunk transactions to be deleted from mempool. + +## 0.23.7 +### Added +- Mempool improvements. + +## 0.23.6 +### Added +- Ability to wipe mempool at start. +- Improvements to mempool processing code. + +## 0.23.5 +### Changed +- Tighten the locking loop to avoid slow cache building. + +## 0.23.5 +### Fixed +- Wrong error in cache when acquiring lock. + +## 0.23.4 +### Added +- Add extra debug logging for cache code. + +### Fixed +- Fix a bug with xpub growing algorithm. + +### Changed +- Use locks instead of transactions to update cache. + +## 0.23.3 +### Fixed +- Reduce contention when many instances of Haskoin Store share a cache. + +## 0.23.2 +### Added +- Allow retrieving xpub data without using cache. + +## 0.23.1 +### Added +- Allow xpub eviction from cache via API. +- Clarify cache address addition code. + +### Fixed +- Balances were incorrectly computed in cache when new transactions arrived. + +## 0.23.0 +### Added +- Support for Redis transactions. +- Use a smaller initial gap for empty xpubs. + +### Changed +- Remove custom JSON encoding class. +- Refactor and code simplification. + +## 0.22.5 +### Fixed +- Cache was being completely pruned. + +## 0.22.4 +### Fixed +- Cache now prunes correctly. + +## 0.22.3 +### Fixed +- Bug was making cache get stuck when pruning. + +## 0.22.2 +### Changed +- More efficient algorithms for caching and cache misses. +- Better debug logging of cache hits and misses. + +## 0.22.1 +### Added +- More debug logging for cache hits. + +### Fixed +- Bug using maximum against empty list. + +## 0.22.0 +### Changed +- Extreme code refactoring. +- Move all code to Haskoin and drop Network from modules. + +### Added +- Use Redis pipelining when importing multiple transactions into cache. +- Implement configurable LRU for Redis cache. +- Import xpubs directly into cache from web worker thread when a key is requested. + +### Removed +- Only expose a few modules to external API. + +## 0.21.7 +### Changed +- Improve build configuration. + +### Fixed +- Use minimum used addresses instead of minimum index for xpub cache decision. + +## 0.21.6 +### Fixed +- Fix missing xpub unspent outputs when using cache. + +## 0.21.5 +### Added +- Only store xpubs in cache if they have more than a threshold addresses used. + +## 0.21.4 +### Fixed +- Fix shared cache case where head is set beyond header chain by another node. + +## 0.21.3 +### Fixed +- Fix bug where best head was not being registered in cache. +- Fix best head in cache being decoded incorrectly. + +## 0.21.2 +### Added +- Complete support for Redis xpub cache. + +## 0.21.1 +### Fixed +- Latest version of secp256k1-haskell works with Debian 9. + +## 0.21.0 +### Fixed +- Fix output of web API calls when issuing limits with offsets. + +### Changed +- Massive refactoring of entire codebase. + +### Added +- Work in progress Redis caching for extended public keys. + +## 0.20.2 +### Changed +- Filter xpub address balances on web API to show only addresses that have been used. + +### Removed +- Remove paths and addresses from xpub summary. + +## 0.20.1 +### Changed +- Refactor code greatly. +- Depend on new Haskoin Store package to avoid missing tx broadcasts. +- Merge StoreStream class into StoreRead. +- Move former streaming functions to use lists instead of conduits. +- Remove excessively verbose debugging. + +## 0.20.0 +### Added +- Set minimum version bounds for some dependencies. +- Now compatible with GHC 8.8. +- Extended key caching system using Redis. + +### Changed +- Massively refactored codebase. +- Less verbose debug logging. + +### Removed +- Removed conduits for faster queries. + +## 0.19.6 +### Added +- Use a parallel strategy to compute key derivations. + +### Fixed +- Do not fail health check upon transaction timeout while syncing. + +### Changed +- Do not use conduits for xpub balance streams. +- Multiple minor refactorings. + +## 0.19.5 +### Changed +- Minor refactor to block import code. + +### Fixed +- Minor fix to transaction timeout check. + +## 0.19.4 +### Fixed +- Clarify and correct health check algorithm. + +## 0.19.3 +### Changed +- Add address transactions to cache. +- Improve multi-address transaction retrieval algorithms. + +## 0.19.2 +### Removed +- Cache-Control header turned out to be unnecessary. + +### Fixed +- Fix some minor errors in web module. + +## 0.19.1 +### Added +- Set Cache-Control header to no-cache. + +## 0.19.0 +### Changed +- Store mempool in single key/value pair. + +## 0.18.11 +### Changed +- Do not stream mempool. + +## 0.18.10 +### Removed +- Disable timeout checks for testnets. + +## 0.18.9 +### Added +- Endpoint to locate a block by unix timestamp. + +### Removed +- No more persistence for peers due to dependency on newest haskoin-node. + +## 0.18.8 +### Added +- Transaction and block timeouts for health check. +- Raw blocks. + +## 0.18.7 +### Fixed +- Missing tranasctions on xpub listings. + +## 0.18.6 +### Removed +- Follow Stack advise removing `-O2` GHC option. + +## 0.18.5 +### Added +- Compatibility with SegWit on extended public key endpoints. + +### Changed +- Fix syncing peer not reset after timeout. +- Use simpler monad for streaming data. + +## 0.18.4 +### Changed +- Bump Haskoin Node to fix peers not stored and excessively verbose logging. + +## 0.18.3 +### Changed +- Configurable HTTP request logging. Disabled by default. + +## 0.18.2 +### Changed +- Fix for memory leak. + +## 0.18.1 +### Removed +- Remove transaction count from xpub summary object. + +## 0.18.0 +### Changed +- Simplified limits and start point handling on web API. +- Made transaction streaming algorithm faster for xpub transactions. +- Extended public key summary output contains all addresses that have received transactions. + +### Added +- Fine-grained control for maximum limits via command line options. +- Transaction hash as starting point. +- Block hash as starting point. +- Timestamp as starting point. +- Configurable xpub gap limit. +- Transaction count added to xpub summary. +- UTXO count added to xpub summary. + +### Removed +- Mempool endpoint now has no limits or offsets and always returns full list. +- Extended public key summary output no longer includes any transactions. +- Offsets not allowed for transaction lists involving multiple addresses or xpubs. +- Confusing block position parameter no longer part of web API. + +## 0.17.2 +### Changed +- Stream address balances and unspent outputs. +- Add configurable max value for limit and offset which defaults at 10000. + +## 0.17.1 +### Changed +- When posting a transaction to the network, timeout is now five seconds. +- Improve error message when transaction post timeout reached. +- Remove obsolete `not found` error for transaction post. +- Endpoints for retrieving blocks now do streaming for better performance. +- Improve Swagger API documentation. + +## 0.17.0 +### Added +- Endpoints for retrieving block transactions. +- Endpoint for retrieving set of latest blocks. + +### Changed +- Use standardized JSON and binary serialization schemes for raw transaction endpoints. + +## 0.16.6 +### Changed +- Now logging info messages too by default. +- Consolidated web logging in middleware. + +### Removed +- UUIDs for web requests. + +## 0.16.5 +### Removed +- Remove concurrency from xpub balance requests to prevent RocksDB segfaults. + +## 0.16.4 +### Removed +- Remove concurrency from requests using iterators to prevent RocksDB from segfaulting. + +## 0.16.3 +### Added +- Debugging information for web API. + +## 0.16.2 +### Changed +- Debugging disabled by default (use `--debug` to enable). + +## 0.16.1 +### Added +- Cache mempool transactions. +- Improve initial syncing performance. + +## 0.16.0 +### Added +- Orphan transaction support. +- Full address balance cache in RocksDB. +- Full unspent output cache in RocksDB. + +### Changed +- Significantly refactor code. +- Move web stuff to its own module. +- Change types related to databases. +- Make xpub balance, transaction and unspent queries fetch data in parallel. + +## 0.15.2 +### Added +- Internal data types to support orphan transactions. + +### Changed +- Do not spam block actor with pings. +- Fix balance/unspent cache not reverting when importing fails. +- Fix transaction sorting algorithm not including transaction position information. +- Fix conflicting mempool transaction preventing block from importing. + +## 0.15.1 +### Changed +- Fix duplicate coinbase transaction id bug. + +## 0.15.0 +### Removed +- Removed `PreciseUnixTime` data type. + +### Changed +- Use 64 bits for Unix time representation. +- Data model now uses simplified Unix time representation. + +## 0.14.9 +### Added +- Last external/change index information to xpub summary object. + +## 0.14.8 +### Added +- Endpoint for xpub summaries. +- Endpoints for full transactions. +- Ability to query by offset/limit. +- More API documentation. + +## 0.14.7 +### Added +- Debug information for `publishTx`. + +### Changed +- Transaction publishing no longer requests mempool. +- Fixed serialization for `TxId` freezing the entire program by infinitely recursing. + +## 0.14.6 +### Changed +- Enable full threading again as it was deemed not responsible for the freezing behaviour. + +## 0.14.5 +### Changed +- Enable threading but leave it at a single thread to be able to open more than 1024 files. + +## 0.14.4 +### Changed +- Target LTS Haskell 13.20 and disable threading in new attempt to fix freezing bug. + +## 0.14.3 +### Changed +- Remove `-O2`. + +## 0.14.2 +### Changed +- Target LTS Haskell 12.26 to attempt to fix freezing bug. + +## 0.14.1 +### Added +- Extra debugging around code that freezes. + +### Changed +- Bump dependency on `haskoin-node`. + +## 0.14.0 +### Removed +- Dump slow protobuf serialization. + +### Added +- Add custom serialization. +- Extra debug logging. + +### Changed +- Bump `haskoin-core` and `haskoin-node`. + +## 0.13.1 +### Changed +- Bump `haskoin-node` in `stack.yaml`. +- Do not send empty `getdata` messages. + +## 0.13.0 +### Added +- Primitive content negotiation for web exceptions. +- Protobuf support for errors. +- Protobuf support for tranasction ids. + +### Changed +- Protobuf format changed in non-backwards-compatible manner for transaction ids. + +## 0.12.0 +### Added +- Support for binary serialization using Protocol Buffers. +- New endpoints for binary raw transactions (not hex-encoded). + +### Changed +- Services field now a hex string instead of a number to avoid overflowing signed 64-bit integer. +- Flatten list of block data objects when responding to request for multiple block heights. +- Errors now reported in plain text without container JSON object. +- Transaction broadcasts are responded to with transaction id in plaintext hex (no JSON). +- Remove database snapshots to improve performance. + +## 0.11.2 +### Changed +- Fix duplicate mempool transaction announcements in event stream. + +## 0.11.1 +### Removed +- Removed latest block time check. + +## 0.11.0 +### Changed +- Improve post transactions endpoint. + +## 0.10.1 +### Changed +- Fix bug where transaction lists from multiple addresses would sort incorrectly. +- Address gap reduced to 20. + +## 0.10.0 +### Removed +- Remove addresses from transaction lists. +- No longer use container objects for xpub transactions. + +## 0.9.3 +### Added +- Permissive CORS headers to allow queries from any domain. +- Improved documentation using real-world examples from the BCH testnet. + +## 0.9.2 +### Added +- HTTP JSON API switch to turn off transaction list when retrieving blocks. + +## 0.9.1 +### Added +- Total block fees. +- Total block outputs. +- Block subsidy. + +### Changed +- Do not consider the blocks less one block away from headers as out of sync in health check. +- Health check now returns HTTP 503 when not OK or out of sync. + +## 0.9.0 +### Added +- Version to health check output. +- Block weight for segwit. +- Transaction weight for segwit. + +## 0.8.1 +### Added +- Health check endpoint. + +## 0.8.0 +### Added +- Limits and skips. +- Add timestamps to transactions. +- Add transaction count to address balance object. +- Add Merkle root to block data. +- Total funds received by an address now shows up in balance. +- Balances for any address that ever had funds show up in xpub endpoints. + +### Changed +- Data model update. +- Performance improvement for xpub calls. +- Transactions are returned in reverse mempool/block order (highest or most recent first). +- Balance objects do not get deleted from database ever. + +## 0.6.9 +### Changed +- Reduce number of coinbase checks to 10,000 ancestors. + +## 0.6.8 +### Changed +- Further optimize coinbase after height checks. + +## 0.6.7 +### Changed +- Impose restrictions on recursion for coinbase after height checks. + +## 0.6.6 +### Added +- Check whether a transaction can be traced back to a coinbase after certain height. + +## 0.6.5 +### Changed +- Delete transactions in reverse topological order when reverting a block. + +## 0.6.4 +### Changed +- Do not fail silently when importing orphan transactions into the mempool. + +## 0.6.3 +### Changed +- Dummy release to bump haskoin-node in stack.yaml. + +## 0.6.2 +### Changed +- Correct bug where coinbase transactions weren't properly flagged. + +## 0.6.1 +### Changed +- Compatibility with Bitcoin Cash hard fork. +- Various bug fixes. + +## 0.6.0 +### Added +- Address balance cache in memory. + +### Changed +- Simplify data model further. +- Fix bug importing outputs with UTXO cache. +- Unspent balances cannot be negative. + +## 0.5.0 +### Added +- Add UTXO cache in memory. +- Get transactions with witness data in segwit networks. + +### Changed +- Paths for derivations in xpubs is a list and no longer a string. +- Various bug fixes. + +## 0.4.2 +### Removed +- Remove extended public key itself from output of relevant endpoints to save bandwidth. + +## 0.4.1 +### Changed +- Fix bug when deleting coinbase transactions. +- Extended public key API support. + +## 0.4.0 +### Changed +- Generate events for mempool transactions. +- Respond with entire block data when querying blocks by height. + +## 0.3.1 +### Changed +- Do not import transactions to mempool while not synced. +- Only sync mempool against a single peer. +- Allow duplicate transactions to fix re-introduced sync bug. + +## 0.3.0 +### Added +- Update dependencies. +- Keep orphan blocks and deleted transactions in database. +- Add a `mainchain` field for block data and a `deleted` field for transactions. +- Stream records for performance. +- Show witness data for transaction inputs in SegWit network. +- Support RBF in SegWit network. + +### Changed +- Refactor all data access code away from actor. +- Refactor import logic away from actor. +- Abstract data access using typeclasses. +- Implement data access using clean layered architecture. +- Make most of import logic code pure. +- Database now in `db` as opposed to `blocks` directory. +- Use latest `haskoin-node`. + +### Removed +- Remove some data from peer information output. +- Remove full transaction from address transaction data. +- Remove limits from address transaction data. +- Remove block data from previous output. +- Remove spender from JSON response when output not spent. +- Remove block hash from block reference. + +## 0.2.3 +### Removed +- Do not send transaction notifications if a block is being imported. + +## 0.2.2 +### Added +- Peer information endpoint. + +### Changed +- Update `haskoin-node`. + +## 0.2.1 +### Changed +- Fix tests + +## 0.2.0 +### Added +- Documentation everywhere. +- Ability to retrieve address transactions. + +### Changed +- New versions of NQE and Haskoin Node upstream. +- Improve and simplify API. +- Multi-element endpoints return arrays of arrays. +- Database snapshots for all queries are now mandatory. + +### Removed +- Retrieving unspent and spent outputs for an address. +- Redundant API endpoints for multiple elements. + +## 0.1.3 +### Changed +- Fix a bug with transaction notifications. +- Improve handling orphan transactions. + +## 0.1.2 +### Changed +- Specify dependencies better. + +## 0.1.1 +### Changed +- Dependency `secp256k1` is now `secp256k1-haskell`. + +## 0.1.0 +### Added +- New `CHANGELOG.md` file. +- Bitcoin (BTC) and Bitcoin Cash (BCH) compatibility. +- RocksDB database. +- Mempool support. +- HTTP streaming for events. +- CashAddr support. +- Bech32 support. +- Rate limits. + +### Changed +- Split out of former `haskoin` repository. +- Use hpack and `package.yaml`. + +### Removed +- Removed Stylish Haskell configuration file. +- Remvoed `haskoin-core` and `haskoin-wallet` packages from this repository. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,936 @@ +# Haskoin Store + +[![CI](https://github.com/jprupp/haskoin-store/actions/workflows/ci.yml/badge.svg)](https://github.com/jprupp/haskoin-store/actions/workflows/ci.yml) +[![Hackage haskoin-store](https://img.shields.io/hackage/v/haskoin-store.svg?label=haskoin-store)](https://hackage.haskell.org/package/haskoin-store) +[![Hackage haskoin-store-data](https://img.shields.io/hackage/v/haskoin-store-data.svg?label=haskoin-store-data)](https://hackage.haskell.org/package/haskoin-store-data) +[![License: MIT](https://img.shields.io/badge/license-MIT-blue.svg)](https://github.com/jprupp/haskoin-store/blob/master/haskoin-store/LICENSE) + +A Bitcoin (BTC) and Bitcoin Cash (BCH) block chain indexer with a REST API, +written in Haskell. It connects to the peer-to-peer network directly, so it +does not need a full node next to it, and keeps its indices in RocksDB. + +- [API reference](https://github.com/jprupp/haskoin-store/blob/master/swagger.yaml) +- [Library documentation](https://hackage.haskell.org/package/haskoin-store) + and [client documentation](https://hackage.haskell.org/package/haskoin-store-data) +- [Changelog](https://github.com/jprupp/haskoin-store/blob/master/CHANGELOG.md) +- [Report a bug](https://github.com/jprupp/haskoin-store/issues) + +## Contents + +- [Why Haskoin Store](#why-haskoin-store) +- [Design principles](#design-principles) +- [Features](#features) +- [Quick start](#quick-start) +- [Building from source](#building-from-source) +- [Running](#running) +- [Tutorial: following a wallet](#tutorial-following-a-wallet) +- [Configuration](#configuration) +- [API](#api) +- [How it works](#how-it-works) +- [Monitoring](#monitoring) +- [Using it from Haskell](#using-it-from-haskell) +- [Packages](#packages) +- [Development](#development) +- [Related projects](#related-projects) +- [License](#license) + +## Why Haskoin Store + +A Bitcoin node can tell you what is in block 800000, but not what the balance +of an address is, which transactions belong to a wallet, or which outputs it +can spend. Wallets, block explorers, payment processors and accounting tools +all need exactly those answers, for many users at once, in milliseconds. + +The usual way to get them is to run a full node and an indexer next to it, and +operate both. Haskoin Store is one program instead. It connects to the +peer-to-peer network itself, downloads blocks and unconfirmed transactions, +keeps indices by address, transaction and extended public key in RocksDB, and +serves them over a REST API. It has been used to serve public Bitcoin and +Bitcoin Cash APIs such as api.haskoin.com. + +## Design principles + +- **Index for the questions people ask.** Every index is laid out so that an + API query is one seek and a short scan in RocksDB, newest first, which keeps + response times flat as the chain grows. +- **Never half-write.** Each block, and each batch of mempool transactions, is + one atomic database write. A crash leaves the store at the previous block, + with no repair step on restart. +- **Unconfirmed transactions matter.** The mempool is indexed and persisted like + the chain, ordered before confirmed history, and handles replace-by-fee on + Bitcoin. A wallet sees a payment the moment the network does. +- **Extended public keys are first class.** Wallets are mostly xpubs, so the + store derives their addresses up to an exact gap, remembers the derivations, + and can keep large wallets ready in a Redis shared by several stores. +- **Bounded resources.** API limits stop one request from monopolising the + server, slow event clients are dropped, and RocksDB memory has a budget. +- **Operable.** A health endpoint that tells a load balancer when an instance is + behind, StatsD metrics for everything, configuration through flags or + environment variables, and a Docker image. +- **Follow the work, not a node.** The store trusts the chain with the most + proof of work, as reported by [haskoin-node](https://github.com/jprupp/haskoin-node), + and checks what it needs to keep its indices consistent. It does not + re-validate scripts; run it against the network you trust, or next to your + own node with `--peer`. + +## Features + +| Area | What you get | +| --------------- | ------------------------------------------------------------------------------------------- | +| Networks | Bitcoin and Bitcoin Cash: mainnet, testnets and regtest | +| Addresses | Balances, transactions and unspent outputs (UTXO) of any address, alone or many at once | +| Xpubs | Balances, transactions and UTXO of extended public keys, for legacy, nested SegWit and native SegWit addresses, with an optional Redis cache for large wallets | +| Blocks and txs | Lookup by hash, height or time; raw serialized forms; transactions of a block | +| Mempool | Persistent, indexed by arrival time, with replace-by-fee on BTC and pruning of old entries | +| Formats | JSON, pretty JSON, or a compact binary encoding | +| Live events | New blocks and transactions as a JSON stream or over a WebSocket | +| Compatibility | Endpoints in the style of Blockchain.info under `/blockchain/` | +| Operations | Health check, StatsD metrics, RocksDB memory limits, Docker image | + +### What is not included + +- No wallet: it never holds keys or signs anything. +- No full validation of scripts and consensus rules. It follows the chain with + the most work and indexes what peers send. +- No address or transaction search by anything but its hash; no indices on + scripts without an address. + +## Quick start + +With [Docker](https://www.docker.com/): + +```sh +git clone https://github.com/jprupp/haskoin-store.git +cd haskoin-store +docker build -t haskoin-store . +docker run -d --name haskoin-store -p 3000:3000 \ + -e NET=btc -e DISCOVER=true \ + -v haskoin-store-data:/home/haskoin/.haskoin-store \ + haskoin-store +curl 'http://localhost:3000/block/best?pretty=true' +``` + +The first sync downloads and indexes the whole chain, which takes a long +time and a lot of disk. The API answers while it syncs; `/health` reports +whether the node is in sync. + +## Building from source + +You need [Stack](https://docs.haskellstack.org/) and three C libraries: +[zlib](https://zlib.net/), +[libsecp256k1](https://github.com/bitcoin-core/secp256k1) and +[RocksDB](https://rocksdb.org/). Stack installs the right GHC by itself. + +**Debian or Ubuntu** + +```sh +sudo apt install git pkg-config zlib1g-dev libsecp256k1-dev librocksdb-dev haskell-stack +``` + +**Fedora** + +```sh +sudo dnf install git pkgconf zlib-devel libsecp256k1-devel rocksdb-devel stack +``` + +Then build and install the `haskoin-store` binary to `~/.local/bin`: + +```sh +git clone https://github.com/jprupp/haskoin-store.git +cd haskoin-store +stack build --copy-bins +~/.local/bin/haskoin-store --help +``` + +**Any distribution, with [Nix](https://nixos.org/)**: Stack fetches the C +libraries listed in `stack.yaml` from Nix instead of the system. + +```sh +stack --nix build --copy-bins +``` + +## Running + +```sh +haskoin-store --net btc --discover +``` + +Give it either `--discover` or at least one `--peer`; with neither it turns +discovery on by itself. Data goes in a directory named after the network inside +`--dir`, so one data directory can hold several networks. + +For a big public deployment, also set `MALLOC_ARENA_MAX=2` (the Docker image +does) to keep glibc from fragmenting RocksDB's memory. + +## Tutorial: following a wallet + +This walks through what a wallet back end typically does with the API, on a +store that is already running on `localhost:3000`. + +### 1. Wait for the store to be ready + +```sh +curl -s -o /dev/null -w '%{http_code}\n' localhost:3000/health +``` + +`200` means the index is caught up with the network. While it syncs you get +`503`, and the body says which check fails. + +### 2. Get the balance of a wallet + +Most wallets are an extended public key. Ask for its summary, and say which +kind of addresses it derives (`legacy`, the default, `compat` for nested +SegWit, `segwit` for native SegWit): + +```sh +curl 'localhost:3000/xpub/xpub6C...?derive=segwit&pretty=true' +``` + +The answer has confirmed and unconfirmed balances, and the index of the last +used receiving and change address, so the wallet knows where to derive the +next address. + +If you get `derive` wrong, the store says so: a wallet with no transactions +of the kind you asked for, but some of another kind, gets a 400 whose message +names the right one, instead of an empty wallet that looks like a zero +balance. + +### 3. List its transactions, page by page + +```sh +curl 'localhost:3000/xpub/xpub6C.../transactions?derive=segwit&limit=50' +``` + +Results are newest first, unconfirmed ones on top. To get the next page, start +from the last transaction you received instead of using an offset: + +```sh +curl 'localhost:3000/xpub/xpub6C.../transactions?derive=segwit&limit=50&offset=1&height=' +``` + +`offset=1` skips the transaction you already have. Paging by starting point +stays fast however deep you go, and does not shift when new transactions +arrive. + +### 4. Find spendable outputs + +```sh +curl 'localhost:3000/xpub/xpub6C.../unspent?derive=segwit' +``` + +Each output comes with its derivation path, so the wallet knows which key signs +it. + +### 5. Broadcast a payment + +```sh +curl -X POST --data-binary @tx.hex localhost:3000/transactions +``` + +The body is the signed transaction in hex. The store sends it to its peers and +returns the transaction id. It appears in the mempool, and in the wallet's +history, as soon as a peer relays it back. + +### 6. Stay up to date without polling + +```sh +curl -N localhost:3000/events +``` + +Each line is a new block or a mempool change. A wallet back end keeps this open +and refreshes the affected wallets when an event arrives, instead of asking +every few seconds. + +After a lost connection, come back with the hash of the last event you +heard, and the stream starts with what came after it: + +```sh +curl -N "localhost:3000/events?after=9a5c…" +``` + +The server keeps its last 10,000 events. It answers 404 when it no longer +has the one you name: read your wallets again, and listen without `after`. + +Over a WebSocket at the same path, a client can ask for only the +transactions it cares about. It sends one or more of these, as text: + +```json +{"type":"watch","addresses":["bc1q…","1A1z…"]} +{"type":"watch","xpub":"xpub6C…","derive":"segwit"} +{"type":"filterload","filter":"b50f","functions":11,"tweak":0,"flags":0} +``` + +From then on it hears of a transaction only when it touches one of the +addresses, an address of the key, or matches the Bloom filter (BIP 37, as +SPV wallets use). Blocks are always sent. A key is followed as a wallet +uses it: the gap of unused addresses moves on as payments come. For a key +with several types of address, send one message for each type. + +A client that connects and then sends its messages gets every transaction +until the first message is read. To start with a choice, put it in the URL, +of the WebSocket or of the HTTP stream: + +```sh +curl -N "localhost:3000/events?quiet=true" # blocks only +curl -N "localhost:3000/events?addresses=bc1q…,1A1z…" +curl -N "localhost:3000/events?xpub=xpub6C…&derive=legacy,segwit" +``` + +`quiet=true` sends blocks alone until the client watches something; a +WebSocket client with a long list connects with it and sends the list in +messages. The [API reference](swagger.yaml) has every message and +parameter, and the binary form of each message. + +### 7. Make big wallets fast + +Start the store with `--redis` and a Redis (or Valkey) server. Xpubs with at +least `--redis-min-addrs` used addresses, or at least `--redis-min-txs` +transactions in their addresses, are then cached after their first +query and answered from Redis, transactions in full included. Several stores +can share one Redis: they keep each other's cache up to date, and a store that +has not imported a transaction yet still serves it from the cache. Add +`nocache=true` to a query to read the database instead. + +Servers behind a load balancer should also be started with `--fleet` +([A fleet of servers](#a-fleet-of-servers)): they then answer every request +alike, and share a cache of xpubs that is built for that. + +## Configuration + +Every option has an environment variable that sets its default, which is handy +in containers. Booleans in variables accept `true`/`false`, `yes`/`no`, +`on`/`off` and `1`/`0`. `haskoin-store --help` shows the current values. + +### Network and peers + +| Option | Environment | Default | Meaning | +| --- | --- | --- | --- | +| `-n`, `--net` | `NET` | `bch` | Network: `btc`, `bch`, or a test network (see `--help`) | +| `-d`, `--dir` | `DIR` | `~/.haskoin-store` | Data directory | +| `--discover` | `DISCOVER` | off | Discover peers through DNS seeds and relayed addresses; on regtest it finds none, so name a `--peer` | +| `-p`, `--peer` | `PEER` | none | Connect to `HOST[:PORT]`; repeat for more, space-separated in `PEER` | +| `--max-peers` | `MAX_PEERS` | `20` | Most peers to connect to | +| `--peer-timeout` | `PEER_TIMEOUT` | `120` | Seconds before an unresponsive peer is dropped | +| `--max-peer-life` | `MAX_PEER_LIFE` | `172800` | Seconds after which a peer is dropped, so connections rotate | +| `--block-window` | `BLOCK_WINDOW` | `64` | Blocks to request from the syncing peer at a time | + +### Mempool + +| Option | Environment | Default | Meaning | +| --- | --- | --- | --- | +| `--no-mempool` | `NO_MEMPOOL` | off | Do not index unconfirmed transactions | +| `--sync-mempool` | `SYNC_MEMPOOL` | off | Ask each peer for its whole mempool once in sync | +| `--wipe-mempool` | `WIPE_MEMPOOL` | off | Empty the mempool area of the database at start | +| `--mempool-timeout` | `MEMPOOL_TIMEOUT` | `14` | Days after which unconfirmed transactions are deleted (0 = never) | + +### Web server and limits + +| Option | Environment | Default | Meaning | +| --- | --- | --- | --- | +| `--host` / `--port` | `HOST` / `PORT` | `*` / `3000` | Address the API listens on | +| `--noweb` | `NO_WEB` | off | Index only, no API | +| `--tls-cert` / `--tls-key` | `TLS_CERT` / `TLS_KEY` | none | Serve HTTPS with this certificate chain and private key, both files in PEM | +| `--no-xpub` | `NO_XPUB` | off | Disable the xpub endpoints | +| `--no-blockchain-info` | `NO_BLOCKCHAIN_INFO` | off | Disable the `/blockchain/` endpoints and price lookups | +| `--max-item-count` | `MAX_ITEM_COUNT` | `200000` | Most items in a list (0 = no limit) | +| `--max-full-item-count` | `MAX_FULL_ITEM_COUNT` | `5000` | Most full transactions in a list (0 = no limit) | +| `--max-offset` | `MAX_OFFSET` | `50000` | Largest `offset` (0 = no limit) | +| `--def-item-count` | `DEF_ITEM_COUNT` | `100` | Items in a list when no `limit` is given | +| `--xpub-gap` | `XPUB_GAP` | `32` | Unused addresses kept after the last used one of each chain of an xpub; payments further away are not seen | +| `--xpub-gap-init` | `XPUB_GAP_INIT` | `20` | Addresses looked at for an xpub with no transactions; an xpub with none used among them counts as unused | +| `--ticker-url` | `TICKER_URL` | Blockchain.info ticker | Source of current prices | +| `--price-history-url` | `PRICE_HISTORY_URL` | Blockchain.info price index | Source of historical prices | +| `--ticker-refresh` | `TICKER_REFRESH` | `90000000` | Microseconds between price updates | + +### Redis cache + +| Option | Environment | Default | Meaning | +| --- | --- | --- | --- | +| `--redis` | `REDIS` | off | Cache large xpubs in Redis | +| `--redis-url` | `REDIS_URL` | local Redis | Redis URL, such as `redis://host:6379` | +| `--redis-min-addrs` | `REDIS_MIN_ADDRS` | `100` | Cache xpubs with at least this many used addresses | +| `--redis-min-txs` | `REDIS_MIN_TXS` | `1000` | Or with at least this many transactions in their addresses | +| `--redis-max-xpubs` | `REDIS_MAX_XPUBS` | `10000` | Evict the least recently used xpubs past this many | + +Every key of the cache starts with `hs2::`, so a Redis can be shared +by stores of several networks, and by stores of older versions, whose cache +uses other keys. `--redis-max-keys` and `--redis-sync-interval` of older +versions are gone. + +### A fleet of servers + +| Option | Environment | Default | Meaning | +| --- | --- | --- | --- | +| `--fleet` | `FLEET` | off | Answer as one of the servers that share the Redis of `--redis` | + +Servers behind a load balancer import the same blocks and transactions at +slightly different times, so the same request can get different answers +depending on which of them it reaches. Start every one of them with +`--redis`, the same `--redis-url` and `--fleet`, and they all answer from +the same block and the same mempool: + +- **The block** is the newest that every live server has. Each server + imports blocks when it gets them and keeps its database as it was at each + of its last six, and a request is answered from the block that the fleet + agreed on. The fleet moves to a new block in one step, when the last + server has it. +- **The mempool** is one pool in Redis, which every server offers its + unconfirmed transactions to and all answer from. A transaction has one + time of arrival there, so lists come in the same order everywhere. +- **A server that falls behind** answers 503 with `behind-fleet` rather + than something that the others would not say, and stops counting after + ten seconds without a report, so that it holds nobody up. A server whose + health check fails stops reporting. +- **`/events` is the same stream on every server.** What changes the + shared mempool or moves the fleet to a block writes an event to Redis + in the same step, and every server sends those events, in that order, + instead of what its own node saw. A block is told when the whole fleet + can answer about it. Each server keeps the same last events, so a + client that reconnects with `after=` may land on any of them. +- **Without Redis** each server answers from its own database, and + `/health` says 203, as it does for the cache. +- **Large xpubs are cached for the whole fleet**, under the same + `--redis-min-addrs`, `--redis-min-txs` and `--redis-max-xpubs` as the + cache of a server alone, which should be the same on every server. An + entry holds the chain's part of a wallet at the block that the fleet + answers from, and the pool's part is kept by the pool itself, so a + cached answer is the one that the database gives, on every server. The + server that moves the fleet to a new block brings the cache there; in + the moment before it has, and for a wallet that just gained or lost an + address, requests are answered from the database. A reorganisation + empties the cache. With it a request about a wallet of 464 addresses + and 19,499 transactions takes 1.3 to 2.2 milliseconds, where it took 5 + to 38. + +The rules, and the tests that hold Redis to them, are described in "A fleet +that answers as one" in `docs/layered-database.md`. + +### Health check + +| Option | Environment | Default | Meaning | +| --- | --- | --- | --- | +| `--max-lagging-blocks` | `MAX_LAGGING_BLOCKS` | `3` | Most blocks the index may lag behind the headers | +| `--max-pending-txs` | `MAX_PENDING_TXS` | `10000` | Most transactions waiting to be imported | +| `--min-peers` | `MIN_PEERS` | `1` | Fewest connected peers | +| `--block-timeout` | `BLOCK_TIMEOUT` | `14400` | Most seconds since the last block | +| `--tx-timeout` | `TX_TIMEOUT` | `1800` | Most seconds since the last transaction | +| `--health-check-interval` | `HEALTH_CHECK_INTERVAL` | `30` | Seconds between checks | + +### Metrics and logging + +| Option | Environment | Default | Meaning | +| --- | --- | --- | --- | +| `--statsd` | `STATSD` | off | Send metrics to StatsD | +| `--statsd-host` / `--statsd-port` | `STATSD_HOST` / `STATSD_PORT` | `localhost` / `8125` | StatsD server | +| `--statsd-prefix` | `STATSD_PREFIX` | `haskoin_store` | Prefix of every metric | +| `--statsd-no-events` | `STATSD_NO_EVENTS` | off | Do not send individual samples | +| `--statsd-aggregates` | `STATSD_AGGREGATES` | off | Also send aggregated statistics every second | +| `--debug` | `DEBUG` | off | Verbose logging | + +### RocksDB + +| Option | Environment | Default | Meaning | +| --- | --- | --- | --- | +| `--no-bloom` | `BLOOM` | on | No Bloom filters on what is read by key; `BLOOM=false` is the same | +| `--max-open-files` | `MAX_OPEN_FILES` | `2000` | Open files; bounds index and filter memory (0 = unlimited) | +| `--write-buffer-mb` | `WRITE_BUFFER_MB` | `256` | Memtables across all column families (0 = unlimited) | +| `--max-wal-mb` | `MAX_WAL_MB` | `1024` | Write-ahead log size that forces flushes (0 = RocksDB default) | +| `--block-cache-mb` | `BLOCK_CACHE_MB` | `1024` | Shared block cache, holding index and filter blocks too (0 = RocksDB default) | + +Memory used by RocksDB is roughly the block cache plus the memtables, on top of +the Haskell heap. `/dbstats` shows where it goes. + +Bloom filters are on by default. They let RocksDB skip the table files that +cannot have a key, which is most of what a lookup of a transaction, an +output or a balance would otherwise read. + +- **What has them:** the data that is read by key: transactions, spenders, + unspent outputs, blocks, balances and the mempool. The two indices by + address, which are scanned, do not. +- **What they cost:** about 1.25 bytes for each key, held in the block + cache. On a chain with billions of keys that is gigabytes: size + `--block-cache-mb` for it, or turn them off with `--no-bloom`. +- **An existing database** gets filters for the table files that are + written from now on, so their memory comes gradually, as RocksDB + compacts. The migration to database version 22 rewrites nearly every + transaction, and with it most of the filters arrive at once. +- **`--bloom`** was the way to turn them on, and is still accepted. Up to + version 1.8.1 it built no filters at all on RocksDB 6.24 or later, + because of a wrong type in the binding, fixed in + `rocksdb-haskell-jprupp` 2.6.3. + +## API + +Full reference: [`swagger.yaml`](swagger.yaml), also served at +[api.haskoin.com](https://api.haskoin.com/). It explains the conventions of +the API (amounts, ordering, paging, formats, errors, unconfirmed transactions +and reorganisations) and the reasons for them, as well as every endpoint. + +```sh +curl localhost:3000/address/bc1q…/balance +curl localhost:3000/xpub/xpub6C…/balances +curl localhost:3000/transaction/ +curl -N localhost:3000/events # stream of new blocks and txs +``` + +- The root of the server, `/`, is the reference of its API as a page that + can try requests, and `/swagger.yaml` the file behind it. +- Add `?pretty=true` for indented JSON. +- Send `Accept: application/octet-stream` for the binary format: see + [Binary format](#binary-format) below. +- Lists are paged with `limit` and `offset`, newest first. `height` begins + a page at a transaction hash, a block hash, a block height or a Unix time + instead. +- Parameters are checked: a parameter that an endpoint does not accept, or + a value it cannot read, gives 400 with a message that names it, instead of + being ignored. The Blockchain.info endpoints accept `format=json`, which + clients written for them often send. +- Errors come back with an HTTP status, in the format that was asked for: + 400 for bad input, 404 for unknown things, 409 when a short transaction + number is ambiguous, 413 for requests that ask for too much. + +### HTTP and HTTPS + +- **`HEAD` and `OPTIONS`** are answered, the second with what a browser + may send from another site. +- **Answers are compressed** for a client that sends + `Accept-Encoding: gzip`, but for the stream of events. +- **Long lists go in a body.** The endpoints that take a list of + addresses, blocks, heights or transactions also take it under `POST`, + as a form (`application/x-www-form-urlencoded`), so that it does not + have to fit in a URL. `/transactions` does not: `POST` there publishes + a transaction. +- **A 503 says when to try again**, in `Retry-After`. +- **HTTPS is optional and off by default.** With `--tls-cert` and + `--tls-key` the server speaks HTTPS on its port, and nothing else. A + public service usually has a proxy in front that holds the certificate; + this is for a server by itself. The files are read at start, so a + renewed certificate takes a restart. + +### Binary format + +Every endpoint but those under `/blockchain/` and `/dbstats` also answers +in a compact binary format, which is smaller and faster to decode than +JSON. The Haskell client in `haskoin-store-data` speaks it, and +`swagger.yaml` has a section, "Binary format", that is enough to write a +client in another language: the primitives, the layout of every type, and +what each endpoint returns. + +- **Ask for it** with `Accept: application/octet-stream`. In a list of + types it wins when its `q` weight is above 0 and no less than that of + `application/json`; a wildcard or no header gives JSON. The answer has + `Content-Type: application/octet-stream`, and every answer has + `Vary: Accept`. +- **Errors come in binary too**: one byte that says which error, and a + message or a list of transactions for those that have one. Up to + version 1.8.1 they were JSON whatever was asked, so a client that also + talks to older servers reads the `Content-Type` of an error. +- **Lists start with their length**, the raw lists of blocks and + transactions included, which up to version 1.8.1 had none. +- **`/events` is the exception**: a stream of events of 33 bytes each, + with no count, for as long as the connection is open. +- **Over the WebSocket** binary is binary frames, for the events and for + the commands that choose transactions. The server answers in the kind + of frame that it was last sent. +- Everything is big-endian, except what is copied from the peer-to-peer + protocol, such as a whole transaction or block. + + +### Endpoints at a glance + +| Area | Endpoints | +| --- | --- | +| Blocks | `/block/best`, `/block/latest`, `/block/:hash`, `/blocks`, `/block/height/:h`, `/block/heights`, `/block/time/:t`, `/block/mtp/:t`, each with a `/raw` variant where it makes sense | +| Transactions | `/transaction/:txid`, `/transactions`, `/transactions/block/:hash`, `/transaction/:txid/after/:height`, `POST /transactions`, `/raw` variants | +| Mempool | `/mempool` | +| Addresses | `/address/:addr/{transactions,transactions/full,balance,unspent}` and the multi-address forms `/address/{transactions,transactions/full,balances,unspent}?addresses=…` | +| Xpubs | `/xpub/:xpub`, `/xpub/:xpub/{transactions,transactions/full,balances,unspent}`, `DELETE /xpub/:xpub` (drop from cache); `derive=legacy\|compat\|segwit` picks the address type (`normal`, the old name of `legacy`, still works) | +| Network | `/peers`, `/health` (503 when unhealthy, 203 without its Redis), `/dbstats` | +| Events | `/events`, as JSON lines over HTTP or as a WebSocket; `after=` resumes, and a WebSocket client can filter by address, xpub or Bloom filter | +| Blockchain.info | `/blockchain/multiaddr`, `/blockchain/balance`, `/blockchain/rawaddr/:addr`, `/blockchain/unspent`, `/blockchain/rawtx/:txid`, `/blockchain/rawblock/:hash`, `/blockchain/latestblock`, `/blockchain/unconfirmed-transactions`, `/blockchain/export-history`, `/blockchain/q/…` | + +Turn off the xpub endpoints with `--no-xpub` and the Blockchain.info ones +with `--no-blockchain-info`. + +## How it works + +``` +peers ──► haskoin-node ──► block store ──► RocksDB ──► web server ──► clients + │ │ ▲ + └─ headers └─ events ──► cache ◄──► Redis ◄──► other stores +``` + +- **haskoin-node** keeps a pool of peers and syncs block headers. +- The **block store** (`Haskoin.Store.BlockStore`) downloads blocks from one + peer at a time and mempool transactions from all of them, and imports them + with the rules in `Haskoin.Store.Logic.Layered`. Each import is one atomic + RocksDB batch, so a crash never leaves a half-written block. +- Reorganisations are handled by reverting blocks until the best block is + back on the main chain of headers. +- The **cache** (`Haskoin.Store.Cache`) keeps xpubs with many used addresses + or many transactions in Redis: their balances, transactions, unspent + outputs and the bodies of their transactions. It never computes an entry + from what it guesses changed: when a block, a mempool transaction or a + reorganisation touches a cached xpub, the store reads from RocksDB, with + the same queries that answer uncached requests, the transactions that + changed and the outputs they create and spend, and writes the differences + in one Lua script, together with every transaction body the entry needs + that Redis does not have yet (bodies it has, such as those of the + transactions a block confirms, are rewritten just before, in small + scripts, so that a large block does not hold Redis for long). + The time of a reload no longer grows with the size of the xpub. The store + reads the whole xpub instead when it first caches it, and whenever it + cannot be sure the entry has every earlier change: when the entry is more + than a block behind, when an address with transactions enters or leaves + the gap, when the balance of an address that no change touched differs + from Redis's and its newest transactions do not explain why, and on a + schedule, every five to ten minutes. The interval depends on the xpub, so + that xpubs cached together are not all read whole at the same moment, + which would hold them all in memory at once. Under load the database is + often a little ahead of the events being applied, so a reload first adds + the transactions that the database has for such an address since the + block the entry was written at, and the mempool transactions of the entry + that have since been confirmed or dropped. The script + writes nothing if the entry changed since it was read, so the entry is + always what the database says; and Redis, which answers one client at a + time, is held for the size of the change, not of the xpub. A page of a + cached xpub is one round trip to Redis. The Lua scripts are in + `src/Haskoin/Store/Cache/lua/`, one file each, embedded in the library + when it is compiled. Stores sharing a Redis claim each change, so it + is applied once, by the first store to see it; a store never replaces an + entry that knows more than its database (a higher block, or a transaction + it has not seen), and a store that is catching up does no cache work. + Without Redis, xpub queries read RocksDB directly. The ways an entry can + still come to differ from the database unnoticed, such as a missed spend of + an output of a cached transaction, and what would rule them out, are in + `docs/cache-consistency.md`. +- A **fleet** (`Haskoin.Store.Fleet.Member`, with `--fleet`) has a cache of + xpubs of another kind (`Haskoin.Store.Fleet.XPub`), because its servers + do not answer from their own databases but from one block and one shared + mempool. An entry has two layers: what the chain has for the addresses of + the xpub at the block that the fleet answers from, and what the shared + pool has for them, which the script of the pool writes as it changes the + pool. The first follows from the chain, so any server writes the same, + and nothing has to be claimed or repaired: the server that moves the + fleet to a new block applies what the block did, and a cache that was + not brought along is emptied. `docs/layered-database.md` has the design, + the tests and the measurements. +- The **web server** (`Haskoin.Store.Web`) answers from RocksDB, and from the + cache for cached xpubs and for transaction bodies that Redis has. + +Xpub addresses are derived up to an exact gap: every address up to the last +used one of each chain, then exactly `--xpub-gap` unused ones, and always the +first `--xpub-gap-init` addresses. A payment further away is not seen, as a +wallet following BIP 44 with the same gap would not see it; raise the gap to +see it. + +An xpub does not record which kind of address its wallet derives, so a +request names it with `derive`. When an xpub has no transactions with the +kind asked for, the store reads the first `--xpub-gap-init` addresses of the +other kinds, and if one of them is used it refuses the request with 400 and +names that kind: an empty answer would look like a wallet with no money, a +mistake that is easy to miss. The extra reads happen only for wallets that +look empty, and not at all on networks without SegWit, which have one kind of +address. + +The database layout is described in `Haskoin.Store.Database.Types`. + +Unconfirmed transactions are kept in an area of their own, and applied on +top of the chain when a query is answered, so that nothing the mempool does +changes the chain's data. This is version 21 of the database, the layered +layout of `docs/layered-database.md`, which has the reasons, the +measurements and the evidence. Up to version 20 they were written into the +same indices as the block chain. A database of version 20 is migrated the +first time this version of the store opens it: its mempool is moved to the +new area, in batches that can be interrupted, and the log says how many +transactions were moved. **There is no way back**: an older store refuses +the database afterwards, so take a copy of a production database first. + +Version 22 makes the record of a confirmed transaction something that is +written once, by the block that confirms it, and the same on every server +that has that block. + +- **Its time is the time of its block.** Until then a server that had seen + a transaction in its mempool kept the time of that when a block + confirmed it, so two servers gave two times for one confirmed + transaction, and a server that synced later gave a third. +- **The spenders of its outputs are under keys of their own**, sixteen + outputs to a key. Until then they were in the record, which was read and + written whole again each time a block spent one of its outputs. Reading + a confirmed transaction in full now takes a second key: 18 microseconds + where it took 11.5, measured, and 0.8 milliseconds for a hundred where + it took 0.4. Lists by address and by xpub do not read records and cost + the same. + +A transaction that leaves the mempool unconfirmed, because it was replaced, +double-spent by a block or too old, is no longer kept: the store forgets +it, and the API answers 404 for it, as it already did. Until version 22 +its body stayed in the database, marked as deleted, for ever. The bodies +that are there in a migrated database are left where they are and +ignored, since finding them would mean reading every transaction. + +A database of version 21, or of version 20 once its mempool is moved, is +brought to this the first time this version of the store opens it. +**The store reads every transaction that it has, and writes nearly every +one again, before it starts**: nothing lists the records that need it, and +most have a spender in them. The log says how far it is every million +transactions. A database of Bitcoin has more than a billion, so plan for +many hours, and for room on the disk for a second copy of the transactions +until RocksDB has compacted the first away. It can be interrupted, and +starts again from the first transaction, skipping what is done. As before, +**there is no way back**: take a copy first. +The parts: + +- the migration from version 20 (`Haskoin.Store.Database.Migrate`); +- the keys that a mempool transaction writes, the summary that is kept for + each address they touch, and what the mempool does to the balance and the + unspent outputs of an address (`Haskoin.Store.Database.Mempool`); +- the rules that import blocks and transactions in that layout + (`Haskoin.Store.Logic.Layered`), which the tests hold to the results of + the rules of version 20, operation by operation and key by key; +- the queries over both areas (`Haskoin.Store.Database.Query.Layered`), each + on a snapshot of the database, one for each request of the web server, + which the tests hold to the answers of the queries of version 20, page by + page. + +The rules and queries of version 20 (`Haskoin.Store.Logic`, +`Haskoin.Store.Database.Query`) stay in the library for those tests, and +nothing in the store calls them. + +## Monitoring + +- **`/health`** returns the result of the latest check as JSON, with status 200 + when every check passes and 503 otherwise. The checks are: index lag behind + the headers, age of the last block and of the last transaction, transactions + waiting to be imported, and connected peers. Point your load balancer at it. +- **Without Redis** a store that has a cache goes on answering, from its own + database, and `/health` says 203 instead of 200, with the header + `Haskoin-Degraded: redis` and `"redis": {"ok": false}` in its JSON. A request waits at most two seconds for Redis + before the store gives up on it, and the store tries again at every health + check. 203 is in the range that load balancers take for healthy, so the + store stays in rotation; alert on anything but 200 to hear of it. +- **StatsD**: with `--statsd`, the store reports the timing of every kind of + request (`web.*`), database reads (`db.*`), cache hits, misses, reloads and + full reloads (`cache.*`), + and block store gauges such as block and header heights and mempool size + (`store.*`). A server of a fleet reports what it does with the fleet's + cache of xpubs under `fleet.cache.*`: + + | Metric | Kind | Meaning | + | --- | --- | --- | + | `fleet.cache.hits` | counter | Requests about an xpub whose balances the cache gave | + | `fleet.cache.misses` | counter | Requests about an xpub that the database answered | + | `fleet.cache.builds` | counter | Entries that this server built, or added addresses to | + | `fleet.cache.build` | timing | Milliseconds to build an entry | + | `fleet.cache.abandoned` | counter | Builds given up because the fleet or the entry moved on | + | `fleet.cache.evictions` | counter | Entries deleted for being the least recently used | + | `fleet.cache.emptied` | counter | Times that this server emptied the cache | + | `fleet.cache.xpubs` | gauge | Xpubs in the cache, whichever server cached them | + | `fleet.cache.addresses` | gauge | Addresses that those xpubs have between them | + + Misses include small xpubs, which are never cached, so the share of hits + says how much of the load the cache takes, not how well it holds what it + has. `fleet.cache.emptied` should move only at a reorganisation or when a + server stops at the wrong moment: the log of the server says why each + time, at the level of information. With `--debug` it also has a line for + each entry built and each block that the cache was brought to. +- **`/dbstats`** returns RocksDB memory use per column family and RocksDB's own + statistics, as text. +- **In a fleet** (`--fleet`), any request can be answered 503 with + `{"error": "behind-fleet"}` by a server that does not have the block that + the fleet answers from. Have the load balancer try another server, and + alert if one keeps saying it: its `/health` will say why. +- **Memory.** The resident memory of the store is its GHC heap plus RocksDB: + the block cache and memtables fill up to `--block-cache-mb` and + `--write-buffer-mb`, then stay there. The executable is built with + `--disable-delayed-os-memory-return`, so memory that the heap no longer + needs goes back to the system at once. Without it, Linux keeps counting + returned memory as resident (`LazyFree` in `/proc//smaps`) until it + needs it, and the heap looks as if it never shrinks after a peak, such as + the full reload of a large cached xpub. Pass `+RTS + --disable-delayed-os-memory-return -RTS` yourself if you build the store + some other way. To tell such memory from a leak, see + `stress/results/2026-11-09-memory/README.md`: how to read `smaps`, and a + heap profile of a busy store, with live data flat at about 10 MiB. +- **Logs** go to standard error, one line per message, tagged with the + component, such as `[Info#BlockStore] Best block: ...`. + +## Using it from Haskell + +Query a running server with `haskoin-store-data`: + +```haskell +import Control.Monad.Except (runExceptT) +import Data.Default (def) +import Haskoin (btc, textToAddr, withContext) +import Haskoin.Store.WebClient + +main :: IO () +main = withContext $ \ctx -> do + let cfg = def {net = btc} -- https://api.haskoin.com/btc/... + Just addr = textToAddr btc "bc1q…" + r <- runExceptT $ apiCall ctx cfg (GetAddrBalance addr) + print r +``` + +The client appends the network name to `host`, as in the layout of +api.haskoin.com. To reach your own server, put it behind a proxy that maps +`/btc/` (or the name of your network) to it. + +Or embed the indexer in your own program with `haskoin-store`: `withStore` +starts the node, the block store and the cache from a `StoreConfig`, and the +functions of `Haskoin.Store.Database.Query.Layered` query its database in +`IO`, on a view of it taken with `withView`, such as +`withView store.db (\v -> getBalance v addr)`. +Subscribe to `Store.pub` to receive `StoreEvent`s. + +Every module has Haddock documentation; build it with `stack haddock`. + +## Packages + +Haskoin Store is two Haskell packages, each in its own repository: + +- **`haskoin-store`**, this repository: the indexer, the web server and the + executable. +- **[`haskoin-store-data`](https://github.com/jprupp/haskoin-store-data)**: + the data types, their JSON and binary encodings, and a client for the API + (`Haskoin.Store.WebClient`). Use this one to talk to a Haskoin Store server + from Haskell. It is small to depend on, as it has no database or node. + +They were released together from this repository up to 1.8.1. A change to +the wire format is made in haskoin-store-data, released, and then picked up +here; `swagger.yaml` stays here and describes the server. + +## Development + +```sh +stack build --test --no-run-tests +stack test # includes a 6000-block heap-growth test +scripts/format # ormolu, the code style used here +scripts/bench-web.sh # load-test the API with wrk +scripts/stress-cache.sh # stress the Redis cache, with a report +scripts/check-local-deps.sh # what CI checks: no local paths in stack.yaml +scripts/install-system-libraries.sh # the C libraries, on Ubuntu or Debian +``` + +`stack.yaml` must pin released versions of every dependency. Pointing +`extra-deps` at a sibling checkout such as `../haskoin-core` is fine for +local testing, but CI rejects it. + +The tests use [hspec](https://hspec.github.io/). The unit tests need no network +access. The integration tests (`Haskoin.Store.IntegrationSpec`) run regtest +chains of Bitcoin Core and Bitcoin Cash Node, and Valkey, in +[Podman](https://podman.io/) containers, and check the store against them: the +exact gap, spends and change, mempool order, multiaddr counts, reorganisations, +and that the cache answers exactly like the database on every xpub endpoint. + +- They are skipped if Podman cannot run containers, or if + `HASKOIN_STORE_NO_PODMAN` is set. +- The first run builds the image `localhost/haskoin-store-test`, which needs + network access: Ubuntu 26.04 pinned by digest, Valkey from a fixed snapshot of + the Ubuntu archive, and the release tarballs of both nodes, checked against + SHA-256 hashes pinned in `test/Haskoin/Store/Integration/Image.hs`. No + third-party image is used. +- Containers are removed when the tests end, data lives in tmpfs mounts and + under `/dev/shm`, and every container has a memory limit. +- Set `HASKOIN_TEST_LOG=1` to print the log of the store under test. + +The test suite runs with at most four cores and a 4 GiB heap, so that a +runaway test fails instead of exhausting the machine. + +`package.yaml` is the source of the package description. Change it rather +than `haskoin-store.cabal`, which +[hpack](https://github.com/sol/hpack) generates. + +### Stress test of the cache + +`scripts/stress-cache.sh [OUT_DIR] [-- OPTIONS]` measures the cache while it +works hard. It runs a regtest chain of Bitcoin Core, Valkey and wrk in Podman +containers from the test image, and the `haskoin-store` binary with the +cache on. A few wallets, whose keys the stress program (`stress/Main.hs`) +holds, make hundreds of thousands of transactions between them, signed by +the program and sent to the node in batches, with a block after each batch. +Every transaction changes two cached xpubs, so the cache reloads them over +and over, while wrk asks the server about the xpubs on five endpoints +(summary, balances, transactions, unspent outputs and multiaddr) the whole +time. At the end it compares the cached answers with those of the database, +and `scripts/stress-report.py` writes `OUT_DIR/report.md`: how fast the +transactions went in, how many reloads the cache did, how many of them read +the whole xpub, and how long they took as the xpubs grew, how far the server +fell behind, its CPU and memory, the +memory of Valkey, the commands that blocked Redis for 10 ms or more (from +its slow log, by script, with the number of arguments of each, which grows +with the size of a commit), and the latencies of each endpoint over time. + +- The defaults are 200,000 transactions between 4 wallets of 200 receiving + and 200 change addresses, 2,000 per block; pass `-- --help` for the + options, and `-- --txs 20000` for a run of a few minutes. A default run + takes about half an hour and up to about 7 GiB of memory. +- The raw measurements stay in `OUT_DIR` as JSON lines (`rounds.jsonl`, + `samples.jsonl`, `wrk.jsonl`), with `summary.json` and the log of the + server. +- No container is left behind, even if the script is interrupted or + killed: the program removes its containers when it ends, and the script + removes any that carry its label and stops the server. +- Results of past runs are kept in `stress/results//` for comparison: + the report, the measurements (without the server log), and a README with + the commits, the machine and what the run found. A new run worth keeping + goes there too. +- To look for a leak, run the server with a heap profile by type, which needs + no profiling build, and summarise it: the live heap over time and the types + of closure that grew most. + + ```sh + scripts/stress-cache.sh /tmp/run -- --txs 60000 \ + --server-rts '-N4 -M2g -T -hT -i10 -po/tmp/heap' + scripts/heap-profile-summary.py /tmp/heap.hp + ``` + +### Measurements for the layered database + +`docs/layered-database/` has the programs behind the numbers in +`docs/layered-database.md`, with their output. They are not part of the +package; each says in its header how to build and run it. + +- `MigrateBench.hs` times the migration to the layered layout against + wiping the same mempool. +- `QueryCost.hs` writes the same synthetic history into a database of each + layout, with each set of rules, and times both: importing blocks and + mempool transactions, and every kind of query, for addresses and wallets + that have nothing, a little and much in the mempool. It checks that both + databases give the same answers. +- `FleetCost.hs` asks one store the same questions alone and as a member + of a fleet, with its mempool in a pool in Redis, checks that the answers + are the same, and times both. It asks about wallets a third way too, + through the fleet's cache of xpubs. + +### Contributing + +Pull requests are welcome. + +- Format the code with `scripts/format` (Ormolu), and keep every line of + code shorter than 120 columns. +- Put scripts in files of their own rather than embedding them: Lua for + Redis under `src/Haskoin/Store/Cache/lua/`, shell under `scripts/`, called + from CI rather than written into the workflow. +- Add tests for the behaviour you change. +- Describe the change under a new version in `CHANGELOG.md`, which follows + [Keep a Changelog](https://keepachangelog.com/en/1.0.0/). +- Update `swagger.yaml` when you change the API. + +## Related projects + +- [haskoin-core](https://github.com/jprupp/haskoin-core) has the Bitcoin data + types and protocol. +- [haskoin-node](https://github.com/jprupp/haskoin-node) connects to peers and + syncs headers. +- [nqe](https://github.com/jprupp/nqe), + [rocksdb-haskell-jprupp](https://github.com/jprupp/rocksdb-haskell), + [rocksdb-query](https://github.com/jprupp/rocksdb-query) and + [statsd-rupp](https://github.com/jprupp/statsd-rupp) provide concurrency, + storage and metrics. + +## License + +Haskoin Store is released under the +[MIT License](https://github.com/jprupp/haskoin-store/blob/master/haskoin-store/LICENSE). diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -1,20 +1,10 @@ {-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE CPP #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ImportQualifiedPost #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedRecordDot #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE NoFieldSelectors #-} module Main (main) where import Control.Monad (when) -import Control.Monad.Cont (ContT (ContT), runContT) -import Control.Monad.Trans (lift) import Data.Char (toLower) import Data.Default (Default (..)) import Data.List (intercalate) @@ -34,7 +24,6 @@ withLogger, withSource, ) -import Haskoin.Store.Common (loopForever) import Haskoin.Store ( Store (..), StoreConfig (..), @@ -43,9 +32,11 @@ runWeb, withStore, ) +import Haskoin.Store.Common (loopForever) import NQE (receive, withSubscription) import Options.Applicative - ( Parser, + ( Mod, + Parser, auto, execParser, flag, @@ -53,6 +44,7 @@ header, help, helper, + hidden, info, long, many, @@ -79,7 +71,6 @@ withStats, ) import Text.Read (readMaybe) -import UnliftIO (MonadIO) import UnliftIO.Directory ( createDirectoryIfMissing, getAppUserDataDirectory, @@ -112,10 +103,11 @@ minPeers :: !Int, webLimits :: !WebLimits, redis :: !Bool, + fleet :: !Bool, redisURL :: !String, redisMinAddrs :: !Int, - redisMaxKeys :: !Integer, - redisSyncInterval :: !Int, + redisMinTxs :: !Int, + redisMaxXPubs :: !Int, noMempool :: !Bool, wipeMempool :: !Bool, syncMempool :: !Bool, @@ -136,6 +128,8 @@ noBlockchainInfo :: !Bool, noXPub :: !Bool, healthCheckInterval :: !Int, + tlsCert :: !String, + tlsKey :: !String, bloom :: !Bool, noWeb :: !Bool, maxOpenFiles :: !Int, @@ -145,13 +139,13 @@ } -- | Read an environment variable with a parser, or return the default if it is unset or invalid. -env :: (MonadIO m) => String -> a -> (String -> Maybe a) -> m a +env :: String -> a -> (String -> Maybe a) -> IO a env e d p = do ms <- lookupEnv e return $ fromMaybe d $ p =<< ms -- | Default configuration, taken from environment variables where set. -defConfig :: (MonadIO m) => m Config +defConfig :: IO Config defConfig = do dir <- getDir @@ -177,14 +171,16 @@ getWebLimits redis <- env "REDIS" False parseBool + fleet <- + env "FLEET" False parseBool redisURL <- env "REDIS_URL" "" pure redisMinAddrs <- env "REDIS_MIN_ADDRS" 100 readMaybe - redisMaxKeys <- - env "REDIS_MAX_KEYS" 100000000 readMaybe - redisSyncInterval <- - env "REDIS_SYNC_INTERVAL" 30 readMaybe + redisMinTxs <- + env "REDIS_MIN_TXS" 1000 readMaybe + redisMaxXPubs <- + env "REDIS_MAX_XPUBS" 10000 readMaybe noMempool <- env "NO_MEMPOOL" False parseBool wipeMempool <- @@ -226,9 +222,13 @@ healthCheckInterval <- env "HEALTH_CHECK_INTERVAL" 30 readMaybe bloom <- - env "BLOOM" False parseBool + env "BLOOM" True parseBool noWeb <- env "NO_WEB" False parseBool + tlsCert <- + env "TLS_CERT" "" pure + tlsKey <- + env "TLS_KEY" "" pure maxOpenFiles <- env "MAX_OPEN_FILES" 2000 readMaybe writeBufferMB <- @@ -283,6 +283,12 @@ "0" -> Just False _ -> Nothing +-- | The help of an option, with the environment variable that sets its +-- default: every option has one, and someone who runs the store in a +-- container reads the help to find its name. +helpEnv :: String -> String -> Mod f a +helpEnv name text = help (text <> " [env: " <> name <> "]") + -- | Command line parser, with defaults from the given configuration. config :: Config -> Parser Config config c = do @@ -291,21 +297,21 @@ metavar "DIRECTORY" <> long "dir" <> short 'd' - <> help "Data directory" + <> helpEnv "DIR" "Data directory" <> showDefault <> value c.dir host <- strOption $ metavar "ADDRESS" <> long "host" - <> help "Network address to bind" + <> helpEnv "HOST" "Network address to bind" <> showDefault <> value c.host port <- option auto $ metavar "PORT" <> long "port" - <> help "REST API listening port" + <> helpEnv "PORT" "REST API listening port" <> showDefault <> value c.port net <- @@ -313,21 +319,21 @@ metavar netNames <> long "net" <> short 'n' - <> help "Network to connect to" + <> helpEnv "NET" "Network to connect to" <> showDefault <> value c.net discover <- flag c.discover True $ long "discover" - <> help "Peer discovery" + <> helpEnv "DISCOVER" "Peer discovery" peers <- fmap (mappend c.peers) $ many $ - option auto $ + strOption $ metavar "HOSTNAME[:PORT]" <> long "peer" <> short 'p' - <> help "Network peer (as many as required)" + <> helpEnv "PEER" "Network peer (as many as required)" version <- switch $ long "version" @@ -336,270 +342,308 @@ debug <- flag c.debug True $ long "debug" - <> help "Show debug messages" + <> helpEnv "DEBUG" "Show debug messages" maxPendingTxs <- option auto $ metavar "COUNT" <> long "max-pending-txs" - <> help "Maximum pending txs to fail health check" + <> helpEnv "MAX_PENDING_TXS" "Maximum pending txs to fail health check" <> showDefault <> value c.maxPendingTxs maxLaggingBlocks <- option auto $ metavar "COUNT" <> long "max-lagging-blocks" - <> help "Maximum number of unindexed blocks" + <> helpEnv "MAX_LAGGING_BLOCKS" "Maximum number of unindexed blocks" <> showDefault <> value c.maxLaggingBlocks minPeers <- option auto $ metavar "COUNT" <> long "min-peers" - <> help "Minimum number of connected peers for health check" + <> helpEnv "MIN_PEERS" "Minimum number of connected peers for health check" <> showDefault <> value c.minPeers noWeb <- flag c.noWeb True $ long "noweb" - <> help "Disable web server" + <> helpEnv "NO_WEB" "Disable web server" webLimits <- do maxItemCount <- option auto $ metavar "COUNT" <> long "max-item-count" - <> help "Hard limit for simple listings (0 = inf)" + <> helpEnv "MAX_ITEM_COUNT" "Hard limit for simple listings (0 = inf)" <> showDefault <> value c.webLimits.maxItemCount maxFullItemCount <- option auto $ metavar "COUNT" <> long "max-full-item-count" - <> help "Hard limit for full listings (0 = inf)" + <> helpEnv "MAX_FULL_ITEM_COUNT" "Hard limit for full listings (0 = inf)" <> showDefault <> value c.webLimits.maxFullItemCount maxOffset <- option auto $ metavar "OFFSET" <> long "max-offset" - <> help "Hard limit for offsets (0 = inf)" + <> helpEnv "MAX_OFFSET" "Hard limit for offsets (0 = inf)" <> showDefault <> value c.webLimits.maxOffset defItemCount <- option auto $ metavar "COUNT" <> long "def-item-count" - <> help "Soft default limit (0 = inf)" + <> helpEnv "DEF_ITEM_COUNT" "Soft default limit (0 = inf)" <> showDefault <> value c.webLimits.defItemCount xpubGap <- option auto $ metavar "GAP" <> long "xpub-gap" - <> help "Max gap for xpub queries" + <> helpEnv "XPUB_GAP" "Max gap for xpub queries" <> showDefault <> value c.webLimits.xpubGap xpubGapInit <- option auto $ metavar "GAP" <> long "xpub-gap-init" - <> help "Max gap for empty xpubs" + <> helpEnv "XPUB_GAP_INIT" "Max gap for empty xpubs" <> showDefault <> value c.webLimits.xpubGapInit blockTimeout <- option auto $ metavar "SECONDS" <> long "block-timeout" - <> help "Block lag health timeout" + <> helpEnv "BLOCK_TIMEOUT" "Block lag health timeout" <> showDefault <> value c.webLimits.blockTimeout txTimeout <- option auto $ metavar "SECONDS" <> long "tx-timeout" - <> help "Last tx received health timeout" + <> helpEnv "TX_TIMEOUT" "Last tx received health timeout" <> showDefault <> value c.webLimits.txTimeout return WebLimits {..} redis <- flag c.redis True $ long "redis" - <> help "Redis cache for xpub data" + <> helpEnv "REDIS" "Redis cache for xpub data" + fleet <- + flag c.fleet True $ + long "fleet" + <> helpEnv + "FLEET" + ( unwords + [ "Answer as one of the servers that share the Redis of --redis:", + "all from the same block and the same mempool" + ] + ) redisURL <- strOption $ metavar "URL" <> long "redis-url" - <> help "URL for Redis cache" + <> helpEnv "REDIS_URL" "URL for Redis cache" <> value c.redisURL redisMinAddrs <- option auto $ - metavar "GAP" + metavar "COUNT" <> long "redis-min-addrs" - <> help "Minimum xpub address count to cache in Redis" + <> helpEnv "REDIS_MIN_ADDRS" "Cache xpubs with at least this many used addresses" <> showDefault <> value c.redisMinAddrs - redisMaxKeys <- + redisMinTxs <- option auto $ metavar "COUNT" - <> long "redis-max-keys" - <> help "Maximum number of keys in Redis" + <> long "redis-min-txs" + <> helpEnv "REDIS_MIN_TXS" "Cache xpubs with at least this many transactions in their addresses" <> showDefault - <> value c.redisMaxKeys - redisSyncInterval <- + <> value c.redisMinTxs + redisMaxXPubs <- option auto $ - metavar "SECONDS" - <> long "redis-sync-interval" - <> help "Sync mempool to Redis interval" + metavar "COUNT" + <> long "redis-max-xpubs" + <> helpEnv "REDIS_MAX_XPUBS" "Evict the least recently used xpubs from Redis past this many" <> showDefault - <> value c.redisSyncInterval + <> value c.redisMaxXPubs noMempool <- flag c.noMempool True $ long "no-mempool" - <> help "Do not index mempool transactions" + <> helpEnv "NO_MEMPOOL" "Do not index mempool transactions" wipeMempool <- flag c.wipeMempool True $ long "wipe-mempool" - <> help "Wipe indexed mempool at start" + <> helpEnv "WIPE_MEMPOOL" "Wipe indexed mempool at start" syncMempool <- flag c.syncMempool True $ long "sync-mempool" - <> help "Attempt to download peer mempools" + <> helpEnv "SYNC_MEMPOOL" "Attempt to download peer mempools" blockWindow <- option auto $ metavar "COUNT" <> long "block-window" - <> help "Blocks to request from the syncing peer at a time" + <> helpEnv "BLOCK_WINDOW" "Blocks to request from the syncing peer at a time" <> showDefault <> value c.blockWindow mempoolTimeout <- option auto $ metavar "DAYS" <> long "mempool-timeout" - <> help "Cull old mempool transactions" + <> helpEnv "MEMPOOL_TIMEOUT" "Cull old mempool transactions" <> showDefault <> value c.mempoolTimeout peerTimeout <- option auto $ metavar "SECONDS" <> long "peer-timeout" - <> help "Unresponsive peer timeout" + <> helpEnv "PEER_TIMEOUT" "Unresponsive peer timeout" <> showDefault <> value c.peerTimeout maxPeerLife <- option auto $ metavar "SECONDS" <> long "max-peer-life" - <> help "Maximum peer connection time" + <> helpEnv "MAX_PEER_LIFE" "Maximum peer connection time" <> showDefault <> value c.maxPeerLife maxPeers <- option auto $ metavar "COUNT" <> long "max-peers" - <> help "Do not connect to more than this many peers" + <> helpEnv "MAX_PEERS" "Do not connect to more than this many peers" <> showDefault <> value c.maxPeers statsd <- flag c.statsd True $ long "statsd" - <> help "Enable statsd metrics" + <> helpEnv "STATSD" "Enable statsd metrics" statsdHost <- strOption $ metavar "HOSTNAME" <> long "statsd-host" - <> help "Host to send statsd metrics" + <> helpEnv "STATSD_HOST" "Host to send statsd metrics" <> showDefault <> value c.statsdHost statsdPort <- option auto $ metavar "PORT" <> long "statsd-port" - <> help "Port to send statsd metrics" + <> helpEnv "STATSD_PORT" "Port to send statsd metrics" <> showDefault <> value c.statsdPort statsdPrefix <- strOption $ metavar "PREFIX" <> long "statsd-prefix" - <> help "Prefix for statsd metrics" + <> helpEnv "STATSD_PREFIX" "Prefix for statsd metrics" <> showDefault <> value c.statsdPrefix statsdNoEvents <- flag c.statsdNoEvents True $ long "statsd-no-events" - <> help "Do not report individual events to statsd" + <> helpEnv "STATSD_NO_EVENTS" "Do not report individual events to statsd" statsdAggregates <- flag c.statsdAggregates True $ long "statsd-aggregates" - <> help "Send statistical aggregate reports to statsd every second" + <> helpEnv "STATSD_AGGREGATES" "Send statistical aggregate reports to statsd every second" tickerRefresh <- option auto $ metavar "MICROSECONDS" <> long "ticker-refresh" - <> help "How often to retrieve price information" + <> helpEnv "TICKER_REFRESH" "How often to retrieve price information" <> showDefault <> value c.tickerRefresh tickerURL <- strOption $ metavar "URL" <> long "ticker-url" - <> help "Blockchain.info price ticker URL" + <> helpEnv "TICKER_URL" "Blockchain.info price ticker URL" <> showDefault <> value c.tickerURL priceHistoryURL <- strOption $ metavar "URL" <> long "price-history-url" - <> help "Blockchain.info price history URL" + <> helpEnv "PRICE_HISTORY_URL" "Blockchain.info price history URL" <> showDefault <> value c.priceHistoryURL noBlockchainInfo <- flag c.noBlockchainInfo True $ long "no-blockchain-info" - <> help "Disable Blockchain.info-style API endpoints" + <> helpEnv "NO_BLOCKCHAIN_INFO" "Disable Blockchain.info-style API endpoints" noXPub <- flag c.noXPub True $ long "no-xpub" - <> help "Disable extended public key support" + <> helpEnv "NO_XPUB" "Disable extended public key support" healthCheckInterval <- option auto $ metavar "SECONDS" <> long "health-check-interval" - <> help "Background check update interval" + <> helpEnv "HEALTH_CHECK_INTERVAL" "Background check update interval" <> showDefault <> value c.healthCheckInterval - bloom <- - flag c.bloom True $ - long "bloom" - <> help "RocksDB Bloom filters" + tlsCert <- + strOption $ + metavar "FILE" + <> long "tls-cert" + <> helpEnv "TLS_CERT" "Serve HTTPS with this certificate chain, in PEM; needs --tls-key" + <> value c.tlsCert + tlsKey <- + strOption $ + metavar "FILE" + <> long "tls-key" + <> helpEnv "TLS_KEY" "Private key of the certificate of --tls-cert, in PEM" + <> value c.tlsKey + noBloom <- + switch $ + long "no-bloom" + <> helpEnv "BLOOM=false" "No RocksDB Bloom filters on the data that is read by key, which are on by default" + -- it was the way to turn them on, and commands that have it must still + -- start + _ <- switch (long "bloom" <> hidden) maxOpenFiles <- option auto $ metavar "COUNT" <> long "max-open-files" - <> help "RocksDB max_open_files; bounds index/filter memory (0 = unlimited)" + <> helpEnv "MAX_OPEN_FILES" "RocksDB max_open_files; bounds index/filter memory (0 = unlimited)" <> showDefault <> value c.maxOpenFiles writeBufferMB <- option auto $ metavar "MB" <> long "write-buffer-mb" - <> help "RocksDB memtable budget across all column families in MiB (0 = unlimited)" + <> helpEnv "WRITE_BUFFER_MB" "RocksDB memtable budget across all column families in MiB (0 = unlimited)" <> showDefault <> value c.writeBufferMB maxWalMB <- option auto $ metavar "MB" <> long "max-wal-mb" - <> help "RocksDB write-ahead log size in MiB that forces flushes so old log files can be deleted (0 = RocksDB default)" + <> helpEnv + "MAX_WAL_MB" + ( unwords + [ "RocksDB write-ahead log size in MiB that forces flushes so old", + "log files can be deleted (0 = RocksDB default)" + ] + ) <> showDefault <> value c.maxWalMB blockCacheMB <- option auto $ metavar "MB" <> long "block-cache-mb" - <> help "RocksDB block cache in MiB, shared by all column families, holding index and filter blocks too (0 = RocksDB default of 32 MiB per column family)" + <> helpEnv + "BLOCK_CACHE_MB" + ( unwords + [ "RocksDB block cache in MiB, shared by all column families,", + "holding index and filter blocks too (0 = RocksDB default of", + "32 MiB per column family)" + ] + ) <> showDefault <> value c.blockCacheMB - pure Config {..} + pure Config {bloom = c.bloom && not noBloom, ..} -- | Network by name. networkReader :: String -> Either String Network @@ -632,19 +676,18 @@ run :: Config -> IO () run cfg = withContext $ \ctx -> - withLogger level $ \logger -> flip runContT return $ do + withLogger level $ \logger -> do net <- either error return $ networkReader cfg.net - stats <- ContT $ with_stats logger net - let dir = cfg.dir net.name - logInfo (withSource "haskoin-store" logger) $ - "Creating working directory (if not found): " <> cs dir - createDirectoryIfMissing True dir - store <- ContT $ run_store logger net ctx stats dir - if cfg.noWeb - then lift . withSubscription store.pub $ \sub -> - loopForever (receive sub) - else do - lift $ run_web logger stats store + with_stats logger net $ \stats -> do + let dir = cfg.dir net.name + logInfo (withSource "haskoin-store" logger) $ + "Creating working directory (if not found): " <> cs dir + createDirectoryIfMissing True dir + run_store logger net ctx stats dir $ \store -> + if cfg.noWeb + then withSubscription store.pub $ \sub -> + loopForever (receive sub) + else run_web logger stats store where run_store logger net ctx stats dir = withStore @@ -656,10 +699,12 @@ net = net, ctx = ctx, redis = if cfg.redis then Just cfg.redisURL else Nothing, + fleet = cfg.fleet, gap = cfg.webLimits.xpubGap, initGap = cfg.webLimits.xpubGapInit, redisMinAddrs = cfg.redisMinAddrs, - redisMaxKeys = cfg.redisMaxKeys, + redisMinTxs = cfg.redisMinTxs, + redisMaxXPubs = cfg.redisMaxXPubs, wipeMempool = cfg.wipeMempool, noMempool = cfg.noMempool, syncMempool = cfg.syncMempool, @@ -669,7 +714,6 @@ maxPeerLife = fromIntegral cfg.maxPeerLife, connect = withConnection, stats = stats, - redisSyncInterval = cfg.redisSyncInterval, bloom = cfg.bloom, maxOpenFiles = if cfg.maxOpenFiles > 0 then Just cfg.maxOpenFiles else Nothing, writeBufferSize = @@ -705,6 +749,11 @@ noXPub = cfg.noXPub, noBlockchainInfo = cfg.noBlockchainInfo, healthCheckInterval = cfg.healthCheckInterval, + tls = case (cfg.tlsCert, cfg.tlsKey) of + ("", "") -> Nothing + ("", _) -> error "--tls-key needs --tls-cert" + (_, "") -> error "--tls-cert needs --tls-key" + (certificate, key) -> Just (certificate, key), logger = withSource "Web" logger } with_stats logger net go diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.hs @@ -1,9 +1,3 @@ -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE ImportQualifiedPost #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedRecordDot #-} -{-# LANGUAGE OverloadedStrings #-} - -- | Load-test server for the web API. -- -- Syncs a synthetic regtest chain from an in-process mock peer into a fresh @@ -20,29 +14,28 @@ module Main (main) where import Conduit -import Control.Monad (forever, unless) -import Control.Monad.Reader (runReaderT) -import Data.ByteString (ByteString) -import Data.ByteString qualified as B -import Data.HashMap.Strict qualified as HashMap -import Data.List (find) import Control.DeepSeq (NFData, force) +import Control.Monad (forever, unless) import Data.Aeson (toEncoding) import Data.Aeson.Encoding (encodingToLazyByteString) +import Data.ByteString (ByteString) +import Data.ByteString qualified as B import Data.Default (def) +import Data.HashMap.Strict qualified as HashMap import Data.IntMap.Strict qualified as IntMap -import Data.Vector qualified as V -import GHC.Clock (getMonotonicTimeNSec) -import Haskoin.Store.Data +import Data.List (find) import Data.Maybe (fromMaybe, listToMaybe, mapMaybe) import Data.Serialize (decode, encode, runGet, runPut) import Data.Text qualified as T import Data.Text.IO qualified as T import Data.Time.Clock.POSIX (getPOSIXTime) +import Data.Vector qualified as V import Data.Word (Word32) +import GHC.Clock (getMonotonicTimeNSec) import Haskoin import Haskoin.Node import Haskoin.Store +import Haskoin.Store.Database.Query qualified as Q import NQE import Network.Socket (SockAddr (..)) import System.Environment (getArgs) @@ -72,7 +65,7 @@ T.putStrLn $ "hot address: " <> addrText net (hotAddr ctx) T.putStrLn $ "xpub: " <> xPubExport net ctx (benchXPub ctx) T.putStrLn $ "xpub address: " <> addrText net (xpubAddr ctx 0 0) - bh <- runReaderT getBestBlock store.db + bh <- Q.getBestBlock store.db T.putStrLn $ "best block: " <> maybe "" blockHashToHex bh putStrLn $ "serving on port " <> show port hFlush stdout @@ -83,7 +76,10 @@ waitHeight :: Store -> Inbox StoreEvent -> Int -> IO () waitHeight store sub n = do - h <- maybe 0 (.height) <$> runReaderT (getBestBlock >>= maybe (return Nothing) getBlock) store.db + h <- + Q.getBestBlock store.db >>= \case + Nothing -> return 0 + Just bh -> maybe 0 (.height) <$> Q.getBlock store.db bh unless (fromIntegral h >= n) $ do _ <- receiveMatch sub $ \case StoreBestBlock b -> Just b @@ -104,9 +100,11 @@ gap = 32, initGap = 20, redisMinAddrs = 20, - redisMaxKeys = 100 * 1000 * 1000, + redisMinTxs = 1000, + redisMaxXPubs = 10000, noMempool = False, wipeMempool = False, + fleet = False, syncMempool = False, blockWindow = 64, mempoolTimeout = 14, @@ -114,7 +112,6 @@ maxPeerLife = 48 * 3600, connect = mockPeer blocks requests net ad, stats = Nothing, - redisSyncInterval = 30, bloom = True, maxOpenFiles = Nothing, writeBufferSize = Nothing, @@ -147,6 +144,7 @@ noXPub = False, noBlockchainInfo = False, healthCheckInterval = 30, + tls = Nothing, logger = quiet } @@ -161,7 +159,9 @@ xpubAddr ctx m i = fst (deriveAddr ctx (pubSubKey ctx (benchXPub ctx) m) i) hotAddr :: Ctx -> Address -hotAddr ctx = pubKeyAddr ctx (derivePublicKey ctx (wrapSecKey True (fromMaybe (error "key") (secKey (B.replicate 32 0x42))))) +hotAddr ctx = pubKeyAddr ctx (derivePublicKey ctx (wrapSecKey True key)) + where + key = fromMaybe (error "key") (secKey (B.replicate 32 0x42)) scriptOf :: Ctx -> Address -> ByteString scriptOf ctx = fromMaybe (error "script") . addressToScriptBS ctx diff --git a/haskoin-store.cabal b/haskoin-store.cabal --- a/haskoin-store.cabal +++ b/haskoin-store.cabal @@ -1,204 +1,362 @@ -cabal-version: 1.12 +cabal-version: 2.0 -- This file has been generated from package.yaml by hpack version 0.39.6. -- -- see: https://github.com/sol/hpack name: haskoin-store -version: 1.8.1 +version: 1.9.0 synopsis: Storage and index for Bitcoin and Bitcoin Cash -description: Please see the README on GitHub at +description: An indexer for Bitcoin and Bitcoin Cash. It downloads blocks and mempool + transactions from the peer-to-peer network, indexes them in RocksDB, and + serves a REST API with balances, transactions and unspent outputs of + addresses and extended public keys, a Blockchain.info compatible API, and + events over WebSockets. An optional Redis cache, shared by several stores, + keeps large wallets fast. See the README for installation and + configuration. category: Bitcoin, Finance, Network -homepage: http://github.com/jprupp/haskoin-store#readme -bug-reports: http://github.com/jprupp/haskoin-store/issues +homepage: https://github.com/jprupp/haskoin-store#readme +bug-reports: https://github.com/jprupp/haskoin-store/issues author: JP Rupp maintainer: jprupp@protonmail.ch +copyright: (c) Haskoin Developers license: MIT license-file: LICENSE build-type: Simple +tested-with: + GHC == 9.12.4 +extra-source-files: + src/Haskoin/Store/Cache/lua/bodies.lua + src/Haskoin/Store/Cache/lua/commit.lua + src/Haskoin/Store/Cache/lua/delete.lua + src/Haskoin/Store/Cache/lua/evict.lua + src/Haskoin/Store/Cache/lua/page.lua + src/Haskoin/Store/Cache/lua/spends.lua + src/Haskoin/Store/Cache/lua/unlock.lua + src/Haskoin/Store/Fleet/lua/move.lua + src/Haskoin/Store/Fleet/lua/pool.lua + src/Haskoin/Store/Fleet/lua/read.lua + src/Haskoin/Store/Fleet/lua/report.lua + src/Haskoin/Store/Fleet/lua/xpub.lua + stress/wrk.lua + swagger.yaml +extra-doc-files: + README.md + CHANGELOG.md source-repository head type: git - location: https://github.com/jprupp/haskoin-store.git + location: https://github.com/jprupp/haskoin-store library exposed-modules: Haskoin.Store Haskoin.Store.BlockStore + Haskoin.Store.BlockStore.Pending + Haskoin.Store.BlockStore.Sync Haskoin.Store.Cache + Haskoin.Store.Cache.Protocol Haskoin.Store.Common + Haskoin.Store.Database.Mempool + Haskoin.Store.Database.Migrate + Haskoin.Store.Database.Query + Haskoin.Store.Database.Query.Layered + Haskoin.Store.Database.Query.Pooled Haskoin.Store.Database.Reader Haskoin.Store.Database.Types + Haskoin.Store.Database.Views Haskoin.Store.Database.Writer + Haskoin.Store.Fleet + Haskoin.Store.Fleet.Member + Haskoin.Store.Fleet.Pool + Haskoin.Store.Fleet.Redis + Haskoin.Store.Fleet.XPub Haskoin.Store.Logic + Haskoin.Store.Logic.Layered Haskoin.Store.Manager Haskoin.Store.Web + Haskoin.Store.Web.Docs + Haskoin.Store.Web.Events + Haskoin.Store.Web.Router other-modules: Paths_haskoin_store + autogen-modules: + Paths_haskoin_store hs-source-dirs: src + default-extensions: + DuplicateRecordFields + NoFieldSelectors + OverloadedRecordDot + OverloadedStrings ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints build-depends: - aeson >=1.4.7.1 - , aeson-pretty >=0.8.8 - , base >=4.9 && <5 - , base16 >=2.0 - , bytes >=0.17 - , bytestring >=0.10.10.0 - , cereal >=0.5.8.1 - , conduit >=1.3.2 - , containers >=0.6.2.1 - , data-default >=0.7.1.1 - , deepseq >=1.4.4.0 - , hashable >=1.3.0.0 - , hashtables >=1.2.4.2 - , haskoin-core >=1.6.1 - , haskoin-node >=2.3.0 - , haskoin-store-data ==1.8.1 - , hedis >=0.16.1 - , http-types >=0.12.3 - , lens >=4.18.1 - , monad-control >=1.0.2.3 - , mtl >=2.2.2 - , network >=3.1.1.1 - , nqe >=0.6.5 - , random >=1.1 - , rocksdb-haskell-jprupp >=2.6.0 - , rocksdb-query >=0.6.0 - , scotty >=0.22 - , statsd-rupp >=0.4 - , stm >=2.5.0.0 - , string-conversions >=0.4.0.1 - , text >=1.2.3.0 - , time >=1.9.3 - , transformers >=0.5.6.2 - , unliftio >=0.2.12.1 - , unordered-containers >=0.2.10.0 - , vault >=0.3.1.5 - , wai >=3.2.2.1 - , wai-websockets >=3.0.1.2 - , warp >=3.3.10 - , websockets >=0.13 - , wreq >=0.5.3.2 - default-language: Haskell2010 + aeson >=2.2.5.1 && <2.3 + , aeson-pretty >=0.8.11 && <0.9 + , base >=4.21.2.0 && <4.22 + , base16 ==2.0.* + , bytes >=0.17.5 && <0.18 + , bytestring >=0.12.2.0 && <0.13 + , case-insensitive >=1.2.1.0 && <1.3 + , cereal >=0.5.8.3 && <0.6 + , conduit >=1.3.6.1 && <1.4 + , containers ==0.7.* + , data-default >=0.8.0.2 && <0.9 + , deepseq >=1.5.1.0 && <1.6 + , file-embed >=0.0.16.0 && <0.1 + , hashable >=1.5.1.0 && <1.6 + , hashtables >=1.4.2 && <1.5 + , haskoin-core >=1.6.1 && <1.7 + , haskoin-node ==2.5.* + , haskoin-store-data ==1.11.* + , hedis >=0.16.4 && <0.17 + , http-types >=0.12.6 && <0.13 + , lens >=5.3.6 && <5.4 + , monad-control >=1.0.3.1 && <1.1 + , mtl >=2.3.2 && <2.4 + , network >=3.2.12.0 && <3.3 + , nqe >=0.6.9 && <0.7 + , random >=1.3.1 && <1.4 + , rocksdb-haskell-jprupp >=2.7.1 && <2.8 + , rocksdb-query >=0.6.1 && <0.7 + , statsd-rupp >=0.5.0.2 && <0.6 + , stm >=2.5.3.1 && <2.6 + , string-conversions >=0.4.0.1 && <0.5 + , text >=2.1.4 && <2.2 + , time ==1.14.* + , transformers >=0.6.3.0 && <0.7 + , unliftio >=0.2.25.1 && <0.3 + , unordered-containers >=0.2.21 && <0.3 + , vault >=0.3.2.0 && <0.4 + , wai >=3.2.5 && <3.3 + , wai-extra >=3.1.18 && <3.2 + , wai-websockets >=3.0.1.2 && <3.1 + , warp >=3.4.17 && <3.5 + , warp-tls >=3.4.14 && <3.5 + , websockets >=0.13.0.0 && <0.14 + , wreq >=0.5.4.5 && <0.6 + default-language: GHC2024 +library integration + exposed-modules: + Haskoin.Store.Integration.Image + Haskoin.Store.Integration.Node + Haskoin.Store.Integration.Podman + Haskoin.Store.Integration.Valkey + other-modules: + Paths_haskoin_store + autogen-modules: + Paths_haskoin_store + hs-source-dirs: + integration + default-extensions: + DuplicateRecordFields + NoFieldSelectors + OverloadedRecordDot + OverloadedStrings + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints + build-depends: + aeson >=2.2.5.1 && <2.3 + , aeson-pretty >=0.8.11 && <0.9 + , base >=4.21.2.0 && <4.22 + , base16 ==2.0.* + , bytes >=0.17.5 && <0.18 + , bytestring >=0.12.2.0 && <0.13 + , case-insensitive >=1.2.1.0 && <1.3 + , cereal >=0.5.8.3 && <0.6 + , conduit >=1.3.6.1 && <1.4 + , containers ==0.7.* + , data-default >=0.8.0.2 && <0.9 + , deepseq >=1.5.1.0 && <1.6 + , file-embed >=0.0.16.0 && <0.1 + , hashable >=1.5.1.0 && <1.6 + , hashtables >=1.4.2 && <1.5 + , haskoin-core >=1.6.1 && <1.7 + , haskoin-node ==2.5.* + , haskoin-store-data ==1.11.* + , hedis >=0.16.4 && <0.17 + , http-types >=0.12.6 && <0.13 + , lens >=5.3.6 && <5.4 + , monad-control >=1.0.3.1 && <1.1 + , mtl >=2.3.2 && <2.4 + , network >=3.2.12.0 && <3.3 + , nqe >=0.6.9 && <0.7 + , process >=1.6.26.1 && <1.7 + , random >=1.3.1 && <1.4 + , rocksdb-haskell-jprupp >=2.7.1 && <2.8 + , rocksdb-query >=0.6.1 && <0.7 + , statsd-rupp >=0.5.0.2 && <0.6 + , stm >=2.5.3.1 && <2.6 + , string-conversions >=0.4.0.1 && <0.5 + , text >=2.1.4 && <2.2 + , time ==1.14.* + , transformers >=0.6.3.0 && <0.7 + , unliftio >=0.2.25.1 && <0.3 + , unordered-containers >=0.2.21 && <0.3 + , vault >=0.3.2.0 && <0.4 + , wai >=3.2.5 && <3.3 + , wai-extra >=3.1.18 && <3.2 + , wai-websockets >=3.0.1.2 && <3.1 + , warp >=3.4.17 && <3.5 + , warp-tls >=3.4.14 && <3.5 + , websockets >=0.13.0.0 && <0.14 + , wreq >=0.5.4.5 && <0.6 + default-language: GHC2024 + executable haskoin-store main-is: Main.hs other-modules: Paths_haskoin_store + autogen-modules: + Paths_haskoin_store hs-source-dirs: app - ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N + default-extensions: + DuplicateRecordFields + NoFieldSelectors + OverloadedRecordDot + OverloadedStrings + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts "-with-rtsopts=-N --disable-delayed-os-memory-return" build-depends: - aeson >=1.4.7.1 - , aeson-pretty >=0.8.8 - , base >=4.9 && <5 - , base16 >=2.0 - , bytes >=0.17 - , bytestring >=0.10.10.0 - , cereal >=0.5.8.1 - , conduit >=1.3.2 - , containers >=0.6.2.1 - , data-default >=0.7.1.1 - , deepseq >=1.4.4.0 - , filepath - , hashable >=1.3.0.0 - , hashtables >=1.2.4.2 - , haskoin-core >=1.6.1 - , haskoin-node >=2.3.0 + aeson >=2.2.5.1 && <2.3 + , aeson-pretty >=0.8.11 && <0.9 + , base >=4.21.2.0 && <4.22 + , base16 ==2.0.* + , bytes >=0.17.5 && <0.18 + , bytestring >=0.12.2.0 && <0.13 + , case-insensitive >=1.2.1.0 && <1.3 + , cereal >=0.5.8.3 && <0.6 + , conduit >=1.3.6.1 && <1.4 + , containers ==0.7.* + , data-default >=0.8.0.2 && <0.9 + , deepseq >=1.5.1.0 && <1.6 + , file-embed >=0.0.16.0 && <0.1 + , filepath >=1.5.5.0 && <1.6 + , hashable >=1.5.1.0 && <1.6 + , hashtables >=1.4.2 && <1.5 + , haskoin-core >=1.6.1 && <1.7 + , haskoin-node ==2.5.* , haskoin-store - , haskoin-store-data ==1.8.1 - , hedis >=0.16.1 - , http-types >=0.12.3 - , lens >=4.18.1 - , monad-control >=1.0.2.3 - , mtl >=2.2.2 - , network >=3.1.1.1 - , nqe >=0.6.5 - , optparse-applicative - , random >=1.1 - , rocksdb-haskell-jprupp >=2.6.0 - , rocksdb-query >=0.6.0 - , scotty >=0.22 - , statsd-rupp >=0.4 - , stm >=2.5.0.0 - , string-conversions >=0.4.0.1 - , text >=1.2.3.0 - , time >=1.9.3 - , transformers >=0.5.6.2 - , unliftio >=0.2.12.1 - , unordered-containers >=0.2.10.0 - , vault >=0.3.1.5 - , wai >=3.2.2.1 - , wai-websockets >=3.0.1.2 - , warp >=3.3.10 - , websockets >=0.13 - , wreq >=0.5.3.2 - default-language: Haskell2010 + , haskoin-store-data ==1.11.* + , hedis >=0.16.4 && <0.17 + , http-types >=0.12.6 && <0.13 + , lens >=5.3.6 && <5.4 + , monad-control >=1.0.3.1 && <1.1 + , mtl >=2.3.2 && <2.4 + , network >=3.2.12.0 && <3.3 + , nqe >=0.6.9 && <0.7 + , optparse-applicative >=0.19.0.0 && <0.20 + , random >=1.3.1 && <1.4 + , rocksdb-haskell-jprupp >=2.7.1 && <2.8 + , rocksdb-query >=0.6.1 && <0.7 + , statsd-rupp >=0.5.0.2 && <0.6 + , stm >=2.5.3.1 && <2.6 + , string-conversions >=0.4.0.1 && <0.5 + , text >=2.1.4 && <2.2 + , time ==1.14.* + , transformers >=0.6.3.0 && <0.7 + , unliftio >=0.2.25.1 && <0.3 + , unordered-containers >=0.2.21 && <0.3 + , vault >=0.3.2.0 && <0.4 + , wai >=3.2.5 && <3.3 + , wai-extra >=3.1.18 && <3.2 + , wai-websockets >=3.0.1.2 && <3.1 + , warp >=3.4.17 && <3.5 + , warp-tls >=3.4.14 && <3.5 + , websockets >=0.13.0.0 && <0.14 + , wreq >=0.5.4.5 && <0.6 + default-language: GHC2024 test-suite spec type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: - Haskoin.Store.BlockStoreSpec + Haskoin.Store.BlockStore.PendingSpec + Haskoin.Store.BlockStore.SyncSpec + Haskoin.Store.Cache.ProtocolSpec Haskoin.Store.CacheSpec Haskoin.Store.CommonSpec + Haskoin.Store.Database.MigrateSpec + Haskoin.Store.Database.Query.LayeredSpec + Haskoin.Store.Database.ViewsSpec + Haskoin.Store.Fleet.MemberSpec + Haskoin.Store.Fleet.PoolSpec + Haskoin.Store.Fleet.RedisSpec + Haskoin.Store.Fleet.XPubSpec + Haskoin.Store.FleetSpec + Haskoin.Store.Histories + Haskoin.Store.IntegrationSpec + Haskoin.Store.Logic.LayeredSpec Haskoin.Store.LogicSpec Haskoin.Store.TestBlocks + Haskoin.Store.Web.EventsSpec + Haskoin.Store.Web.RouterSpec Haskoin.Store.WebSpec Haskoin.StoreSpec Paths_haskoin_store + autogen-modules: + Paths_haskoin_store hs-source-dirs: test - ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts "-with-rtsopts=-N -T" + default-extensions: + DuplicateRecordFields + NoFieldSelectors + OverloadedRecordDot + OverloadedStrings + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts "-with-rtsopts=-N4 -T -M4g" build-depends: - QuickCheck >=2.13.2 - , aeson >=1.4.7.1 - , aeson-pretty >=0.8.8 - , base >=4.9 && <5 - , base16 >=2.0 - , base64 >=0.4.1 - , bytes >=0.17 - , bytestring >=0.10.10.0 - , cereal >=0.5.8.1 - , conduit >=1.3.2 - , containers >=0.6.2.1 - , data-default >=0.7.1.1 - , deepseq >=1.4.4.0 - , fast-logger >=3.0 - , hashable >=1.3.0.0 - , hashtables >=1.2.4.2 - , haskoin-core >=1.6.1 - , haskoin-node >=2.3.0 + QuickCheck >=2.17.1.0 && <2.18 + , aeson >=2.2.5.1 && <2.3 + , aeson-pretty >=0.8.11 && <0.9 + , base >=4.21.2.0 && <4.22 + , base16 ==2.0.* + , base64 >=1.0.1 && <1.1 + , bytes >=0.17.5 && <0.18 + , bytestring >=0.12.2.0 && <0.13 + , case-insensitive >=1.2.1.0 && <1.3 + , cereal >=0.5.8.3 && <0.6 + , conduit >=1.3.6.1 && <1.4 + , containers ==0.7.* + , data-default >=0.8.0.2 && <0.9 + , deepseq >=1.5.1.0 && <1.6 + , fast-logger >=3.2.9 && <3.3 + , file-embed >=0.0.16.0 && <0.1 + , hashable >=1.5.1.0 && <1.6 + , hashtables >=1.4.2 && <1.5 + , haskoin-core >=1.6.1 && <1.7 + , haskoin-node ==2.5.* , haskoin-store - , haskoin-store-data ==1.8.1 - , hedis >=0.16.1 - , hspec >=2.7.1 - , http-types >=0.12.3 - , lens >=4.18.1 - , monad-control >=1.0.2.3 - , mtl >=2.2.2 - , network >=3.1.1.1 - , nqe >=0.6.5 - , random >=1.1 - , rocksdb-haskell-jprupp >=2.6.0 - , rocksdb-query >=0.6.0 - , scotty >=0.22 - , statsd-rupp >=0.4 - , stm >=2.5.0.0 - , string-conversions >=0.4.0.1 - , text >=1.2.3.0 - , time >=1.9.3 - , transformers >=0.5.6.2 - , unliftio >=0.2.12.1 - , unordered-containers >=0.2.10.0 - , vault >=0.3.1.5 - , wai >=3.2.2.1 - , wai-websockets >=3.0.1.2 - , warp >=3.3.10 - , websockets >=0.13 - , wreq >=0.5.3.2 - default-language: Haskell2010 + , haskoin-store-data ==1.11.* + , hedis >=0.16.4 && <0.17 + , hspec >=2.11.18 && <2.12 + , http-types >=0.12.6 && <0.13 + , integration + , lens >=5.3.6 && <5.4 + , monad-control >=1.0.3.1 && <1.1 + , mtl >=2.3.2 && <2.4 + , network >=3.2.12.0 && <3.3 + , nqe >=0.6.9 && <0.7 + , process >=1.6.26.1 && <1.7 + , random >=1.3.1 && <1.4 + , rocksdb-haskell-jprupp >=2.7.1 && <2.8 + , rocksdb-query >=0.6.1 && <0.7 + , statsd-rupp >=0.5.0.2 && <0.6 + , stm >=2.5.3.1 && <2.6 + , string-conversions >=0.4.0.1 && <0.5 + , text >=2.1.4 && <2.2 + , time ==1.14.* + , transformers >=0.6.3.0 && <0.7 + , unliftio >=0.2.25.1 && <0.3 + , unordered-containers >=0.2.21 && <0.3 + , vault >=0.3.2.0 && <0.4 + , wai >=3.2.5 && <3.3 + , wai-extra >=3.1.18 && <3.2 + , wai-websockets >=3.0.1.2 && <3.1 + , warp >=3.4.17 && <3.5 + , warp-tls >=3.4.14 && <3.5 + , websockets >=0.13.0.0 && <0.14 + , wreq >=0.5.4.5 && <0.6 + default-language: GHC2024 build-tool-depends: hspec-discover:hspec-discover benchmark haskoin-store-bench @@ -206,51 +364,127 @@ main-is: Main.hs other-modules: Paths_haskoin_store + autogen-modules: + Paths_haskoin_store hs-source-dirs: bench + default-extensions: + DuplicateRecordFields + NoFieldSelectors + OverloadedRecordDot + OverloadedStrings ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N build-depends: - aeson >=1.4.7.1 - , aeson-pretty >=0.8.8 - , base >=4.9 && <5 - , base16 >=2.0 - , bytes >=0.17 - , bytestring >=0.10.10.0 - , cereal >=0.5.8.1 - , conduit >=1.3.2 - , containers >=0.6.2.1 - , data-default >=0.7.1.1 - , deepseq >=1.4.4.0 - , hashable >=1.3.0.0 - , hashtables >=1.2.4.2 - , haskoin-core >=1.6.1 - , haskoin-node >=2.3.0 + aeson >=2.2.5.1 && <2.3 + , aeson-pretty >=0.8.11 && <0.9 + , base >=4.21.2.0 && <4.22 + , base16 ==2.0.* + , bytes >=0.17.5 && <0.18 + , bytestring >=0.12.2.0 && <0.13 + , case-insensitive >=1.2.1.0 && <1.3 + , cereal >=0.5.8.3 && <0.6 + , conduit >=1.3.6.1 && <1.4 + , containers ==0.7.* + , data-default >=0.8.0.2 && <0.9 + , deepseq >=1.5.1.0 && <1.6 + , file-embed >=0.0.16.0 && <0.1 + , hashable >=1.5.1.0 && <1.6 + , hashtables >=1.4.2 && <1.5 + , haskoin-core >=1.6.1 && <1.7 + , haskoin-node ==2.5.* , haskoin-store - , haskoin-store-data ==1.8.1 - , hedis >=0.16.1 - , http-types >=0.12.3 - , lens >=4.18.1 - , monad-control >=1.0.2.3 - , mtl >=2.2.2 - , network >=3.1.1.1 - , nqe >=0.6.5 - , random >=1.1 - , rocksdb-haskell-jprupp >=2.6.0 - , rocksdb-query >=0.6.0 - , scotty >=0.22 - , statsd-rupp >=0.4 - , stm >=2.5.0.0 - , string-conversions >=0.4.0.1 - , text >=1.2.3.0 - , time >=1.9.3 - , transformers >=0.5.6.2 - , unliftio >=0.2.12.1 - , unordered-containers >=0.2.10.0 - , vault >=0.3.1.5 - , vector - , wai >=3.2.2.1 - , wai-websockets >=3.0.1.2 - , warp >=3.3.10 - , websockets >=0.13 - , wreq >=0.5.3.2 - default-language: Haskell2010 + , haskoin-store-data ==1.11.* + , hedis >=0.16.4 && <0.17 + , http-types >=0.12.6 && <0.13 + , lens >=5.3.6 && <5.4 + , monad-control >=1.0.3.1 && <1.1 + , mtl >=2.3.2 && <2.4 + , network >=3.2.12.0 && <3.3 + , nqe >=0.6.9 && <0.7 + , random >=1.3.1 && <1.4 + , rocksdb-haskell-jprupp >=2.7.1 && <2.8 + , rocksdb-query >=0.6.1 && <0.7 + , statsd-rupp >=0.5.0.2 && <0.6 + , stm >=2.5.3.1 && <2.6 + , string-conversions >=0.4.0.1 && <0.5 + , text >=2.1.4 && <2.2 + , time ==1.14.* + , transformers >=0.6.3.0 && <0.7 + , unliftio >=0.2.25.1 && <0.3 + , unordered-containers >=0.2.21 && <0.3 + , vault >=0.3.2.0 && <0.4 + , vector >=0.13.2.0 && <0.14 + , wai >=3.2.5 && <3.3 + , wai-extra >=3.1.18 && <3.2 + , wai-websockets >=3.0.1.2 && <3.1 + , warp >=3.4.17 && <3.5 + , warp-tls >=3.4.14 && <3.5 + , websockets >=0.13.0.0 && <0.14 + , wreq >=0.5.4.5 && <0.6 + default-language: GHC2024 + +benchmark haskoin-store-stress + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: + Paths_haskoin_store + autogen-modules: + Paths_haskoin_store + hs-source-dirs: + stress + default-extensions: + DuplicateRecordFields + NoFieldSelectors + OverloadedRecordDot + OverloadedStrings + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N2 + build-depends: + aeson >=2.2.5.1 && <2.3 + , aeson-pretty >=0.8.11 && <0.9 + , base >=4.21.2.0 && <4.22 + , base16 ==2.0.* + , bytes >=0.17.5 && <0.18 + , bytestring >=0.12.2.0 && <0.13 + , case-insensitive >=1.2.1.0 && <1.3 + , cereal >=0.5.8.3 && <0.6 + , conduit >=1.3.6.1 && <1.4 + , containers ==0.7.* + , data-default >=0.8.0.2 && <0.9 + , deepseq >=1.5.1.0 && <1.6 + , file-embed >=0.0.16.0 && <0.1 + , hashable >=1.5.1.0 && <1.6 + , hashtables >=1.4.2 && <1.5 + , haskoin-core >=1.6.1 && <1.7 + , haskoin-node ==2.5.* + , haskoin-store + , haskoin-store-data ==1.11.* + , hedis >=0.16.4 && <0.17 + , http-types >=0.12.6 && <0.13 + , integration + , lens >=5.3.6 && <5.4 + , monad-control >=1.0.3.1 && <1.1 + , mtl >=2.3.2 && <2.4 + , network >=3.2.12.0 && <3.3 + , nqe >=0.6.9 && <0.7 + , optparse-applicative >=0.19.0.0 && <0.20 + , process >=1.6.26.1 && <1.7 + , random >=1.3.1 && <1.4 + , rocksdb-haskell-jprupp >=2.7.1 && <2.8 + , rocksdb-query >=0.6.1 && <0.7 + , statsd-rupp >=0.5.0.2 && <0.6 + , stm >=2.5.3.1 && <2.6 + , string-conversions >=0.4.0.1 && <0.5 + , text >=2.1.4 && <2.2 + , time ==1.14.* + , transformers >=0.6.3.0 && <0.7 + , unliftio >=0.2.25.1 && <0.3 + , unordered-containers >=0.2.21 && <0.3 + , vault >=0.3.2.0 && <0.4 + , wai >=3.2.5 && <3.3 + , wai-extra >=3.1.18 && <3.2 + , wai-websockets >=3.0.1.2 && <3.1 + , warp >=3.4.17 && <3.5 + , warp-tls >=3.4.14 && <3.5 + , websockets >=0.13.0.0 && <0.14 + , wreq >=0.5.4.5 && <0.6 + default-language: GHC2024 diff --git a/integration/Haskoin/Store/Integration/Image.hs b/integration/Haskoin/Store/Integration/Image.hs new file mode 100644 --- /dev/null +++ b/integration/Haskoin/Store/Integration/Image.hs @@ -0,0 +1,196 @@ +-- | +-- Module : Haskoin.Store.Integration.Image +-- Copyright : (c) Haskoin Developers +-- License : MIT +-- Maintainer : jprupp@protonmail.ch +-- Stability : experimental +-- Portability : POSIX +-- +-- The container image of the integration tests, built from pinned and +-- verified sources only. +-- +-- The tests use no third-party images. The image starts from the official +-- Ubuntu 26.04 image, pinned by the digest of its multi-architecture index, +-- installs Valkey (the Redis-compatible server Ubuntu ships) and wrk from the +-- Ubuntu archive at a fixed snapshot date (apt checks the signatures of the +-- archive; the certificates needed to reach the snapshot service over HTTPS +-- come from the regular archive first), and downloads Bitcoin Core and +-- Bitcoin Cash Node from their official release locations, checking each +-- tarball against a SHA-256 hash pinned here. A tarball that does not match +-- stops the build. +-- +-- The hashes were taken from the signed checksum files of each release and +-- checked against the release signing keys of each project when they were +-- pinned: +-- +-- * Bitcoin Core 32.1: @SHA256SUMS@ from bitcoincore.org, with good +-- signatures from eight of the builders whose keys are in the +-- @bitcoin-core/guix.sigs@ repository; +-- * Bitcoin Cash Node 29.2.0: @SHA256SUMS.29.2.0.asc.*@ from the +-- @bitcoin-cash-node/announcements@ repository, with good signatures from +-- two maintainers whose keys are in @contrib/gitian-signing/pubkeys.txt@. +-- +-- To move to new releases, change the versions and hashes below after +-- checking them the same way. The tag of the image is a hash of the whole +-- recipe, so a change builds a new image and the old one is no longer used. +module Haskoin.Store.Integration.Image + ( testImage, + coreBin, + bchnBin, + valkeyBin, + wrkBin, + ) +where + +import Data.ByteString.Char8 qualified as C8 +import Data.List (intercalate) +import Data.Serialize (encode) +import Data.Text qualified as T +import Haskoin (encodeHex, sha256) +import System.Exit (ExitCode (..)) +import System.Process (readProcessWithExitCode) +import UnliftIO.Temporary (withSystemTempDirectory) + +-- | Ubuntu 26.04, by the digest of its multi-architecture index. +base :: String +base = "docker.io/library/ubuntu@sha256:6a06111c3b0a8600feadb270aec771dc239bf407b25625f93f44ab00e11f4d3c" + +-- | Date of the snapshot of the Ubuntu archive to install packages from, so +-- that the same versions are installed every time. +snapshot :: String +snapshot = "20261101T000000Z" + +-- | Bitcoin Core release and the hashes of its Linux tarballs for x86_64 and +-- aarch64. +coreVersion, coreAmd64, coreArm64 :: String +coreVersion = "32.1" +coreAmd64 = "61545c17c3120fb7412f896d248b11993af04ec8817aad3649c55b2afb044963" +coreArm64 = "7ed37c7373eb6aa3e3f72842596a1afeba1b223717033cade9842b25773e1922" + +-- | Bitcoin Cash Node release and the hashes of its Linux tarballs for x86_64 +-- and aarch64. +bchnVersion, bchnAmd64, bchnArm64 :: String +bchnVersion = "29.2.0" +bchnAmd64 = "23bbe9ff749136a9b832a2a59023ce76a5391322c1ea2f4f24b5b91f035081bc" +bchnArm64 = "27e177e5a07dc78c2c0d18798ea2e3925111955509ecdc476e828e7ce8f46383" + +-- | Daemon of Bitcoin Core in the image. +coreBin :: String +coreBin = "/opt/bitcoin-core/bin/bitcoind" + +-- | Daemon of Bitcoin Cash Node in the image. +bchnBin :: String +bchnBin = "/opt/bitcoin-cash-node/bin/bitcoind" + +-- | Valkey server in the image. +valkeyBin :: String +valkeyBin = "/usr/bin/valkey-server" + +-- | The HTTP load generator wrk in the image, for the stress test of the +-- cache. +wrkBin :: String +wrkBin = "/usr/bin/wrk" + +-- | Recipe of the image. +-- +-- Every download is its own layer, ordered from the one that changes least +-- often: the packages of the snapshot, then Bitcoin Core, then Bitcoin Cash +-- Node, then wrk for the stress test, which came last. Podman keeps the +-- layers it builds and reuses each one whose instruction, and those before +-- it, did not change, so moving one node to a new release downloads only +-- that release. Nothing in the image depends on the time it is built. +-- +-- The recipe stays here rather than in a Containerfile of its own: it is +-- made from the versions and hashes defined in this module, and the tag of +-- the image is a hash of it, so the tests and the stress program, which may +-- run from any directory, need no file to find. It is written one +-- instruction and one shell command per line. +containerfile :: String +containerfile = + unlines $ + [ "FROM " <> base, + "ARG TARGETARCH", + -- the snapshot archive is only served over HTTPS, so first get the + -- certificates to reach it from the regular archive (over HTTP, with + -- the packages checked by the signatures of the archive), then install + -- everything, the certificates included, from the snapshot + "RUN apt-get update --error-on=any \\", + " && apt-get install -y --no-install-recommends ca-certificates \\", + " && apt-get update --error-on=any --snapshot " <> snapshot <> " \\", + " && apt-get install -y --no-install-recommends --snapshot " + <> snapshot + <> " ca-certificates curl valkey-server \\", + " && rm -rf /var/lib/apt/lists/*" + ] + <> release + "/opt/bitcoin-core" + ( "https://bitcoincore.org/bin/bitcoin-core-" + <> coreVersion + <> "/bitcoin-" + <> coreVersion + <> "-$a-linux-gnu.tar.gz" + ) + coreAmd64 + coreArm64 + <> release + "/opt/bitcoin-cash-node" + ( "https://github.com/bitcoin-cash-node/bitcoin-cash-node/releases/download/v" + <> bchnVersion + <> "/bitcoin-cash-node-" + <> bchnVersion + <> "-$a-linux-gnu.tar.gz" + ) + bchnAmd64 + bchnArm64 + <> [ "RUN apt-get update --error-on=any --snapshot " <> snapshot <> " \\", + " && apt-get install -y --no-install-recommends --snapshot " <> snapshot <> " wrk \\", + " && rm -rf /var/lib/apt/lists/*" + ] + where + -- download a release for the architecture of the image, check its hash, + -- and unpack it; @$a@ in the URL stands for the architecture + release dir url amd64 arm64 = + [ "RUN set -eu; \\", + " case \"$TARGETARCH\" in \\", + " amd64) a=x86_64; h=" <> amd64 <> ";; \\", + " arm64) a=aarch64; h=" <> arm64 <> ";; \\", + " *) echo \"unsupported architecture $TARGETARCH\"; exit 1;; \\", + " esac; \\", + " curl -fsSL -o /tmp/release.tar.gz \"" <> url <> "\"; \\", + " echo \"$h /tmp/release.tar.gz\" | sha256sum -c -; \\", + " mkdir -p " <> dir <> "; \\", + " tar -xzf /tmp/release.tar.gz -C " <> dir <> " --strip-components=1; \\", + " rm /tmp/release.tar.gz" + ] + +-- | Tag of the image: a hash of its recipe. +tag :: String +tag = + "localhost/haskoin-store-test:" + <> take 16 (T.unpack (encodeHex (encode (sha256 (C8.pack containerfile))))) + +-- | Build the image unless it exists already, and return its tag. The first +-- build downloads the base image, the packages and the two releases, and may +-- take a few minutes; later builds of a changed recipe reuse the layers that +-- did not change (see the recipe above). Images and layers are never removed by +-- the tests. The build may use 1 GiB of memory. +testImage :: IO String +testImage = do + (exists, _, _) <- readProcessWithExitCode "podman" ["image", "exists", tag] "" + case exists of + ExitSuccess -> return tag + _ -> withSystemTempDirectory "haskoin-store-image" $ \ctx -> do + (code, out, err) <- + readProcessWithExitCode + "podman" + ["build", "--layers", "--memory", "1g", "--tag", tag, "--file", "-", ctx] + containerfile + case code of + ExitSuccess -> return tag + _ -> + fail $ + intercalate + "\n" + ["Could not build the test image " <> tag <> ":", lastLines out, lastLines err] + where + lastLines = unlines . reverse . take 30 . reverse . lines diff --git a/integration/Haskoin/Store/Integration/Node.hs b/integration/Haskoin/Store/Integration/Node.hs new file mode 100644 --- /dev/null +++ b/integration/Haskoin/Store/Integration/Node.hs @@ -0,0 +1,237 @@ +-- | +-- Module : Haskoin.Store.Integration.Node +-- Copyright : (c) Haskoin Developers +-- License : MIT +-- Maintainer : jprupp@protonmail.ch +-- Stability : experimental +-- Portability : POSIX +-- +-- Regtest nodes for the integration tests: Bitcoin Core for Bitcoin and +-- Bitcoin Cash Node for Bitcoin Cash, each in a container, driven through +-- JSON-RPC. +-- +-- A regtest node gives the tests a chain they fully control: they mine blocks +-- on demand, send transactions from the wallet of the node, and sign +-- transactions that spend from the keys of the test xpubs. The store under +-- test connects to the node over the peer-to-peer protocol, as it would to +-- the real networks. +-- +-- Only RPC calls that both nodes have are used. Bitcoin Cash Node has no +-- @generateblock@, so the reorganisation test is built on coinbase maturity +-- instead (see "Haskoin.Store.IntegrationSpec"). +module Haskoin.Store.Integration.Node + ( NodeKind (..), + Node (..), + nodeContainer, + nodeNetwork, + RpcError (..), + rpc, + waitRpc, + ensureWallet, + field, + textField, + btc, + sats, + getNewAddress, + generateTo, + sendTo, + sendMany, + getRawTx, + bestBlockHash, + rawMempool, + ) +where + +import Control.Lens ((&), (?~), (^.)) +import Control.Monad (void) +import Data.Aeson (Value (..), eitherDecode, object, (.=)) +import Data.Aeson.Key qualified as Key +import Data.Aeson.KeyMap qualified as KeyMap +import Data.Foldable (toList) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Word (Word64) +import Haskoin (Network, bchRegTest, btcRegTest) +import Haskoin.Store.Integration.Image (bchnBin, coreBin) +import Haskoin.Store.Integration.Podman (ContainerSpec (..)) +import Network.Wreq qualified as Wreq +import UnliftIO (Exception, throwIO, tryAny) +import UnliftIO.Concurrent (threadDelay) + +-- | Which node software. +data NodeKind = BitcoinCore | BitcoinCashNode + deriving (Eq, Show) + +-- | A node and how to reach it. +data Node = Node + { kind :: !NodeKind, + -- | URL of the JSON-RPC interface + url :: !String, + -- | port of the peer-to-peer interface on 127.0.0.1 + p2p :: !Int + } + +-- | Network constants of the regtest chain of a node. +nodeNetwork :: NodeKind -> Network +nodeNetwork BitcoinCore = btcRegTest +nodeNetwork BitcoinCashNode = bchRegTest + +-- | Container of a regtest node, from the test image +-- ("Haskoin.Store.Integration.Image"): its chain is in a tmpfs of 512 MiB, +-- it may use 1 GiB of memory, and its caches and mempool are kept small. +-- +-- Every peer is whitelisted, so that the store may ask for the mempool and +-- gets transactions relayed without delay. +nodeContainer :: NodeKind -> String -> ContainerSpec +nodeContainer kind image = + ContainerSpec + { name = case kind of + BitcoinCore -> "bitcoin-core" + BitcoinCashNode -> "bitcoin-cash-node", + image = image, + options = + [ "--memory", + "1g", + "--tmpfs", + "/chain:rw,size=512m,mode=1777", + "--entrypoint", + case kind of + BitcoinCore -> coreBin + BitcoinCashNode -> bchnBin + ], + command = + [ "-regtest", + "-datadir=/chain", + "-printtoconsole", + "-server", + "-rpcuser=test", + "-rpcpassword=test", + "-rpcbind=0.0.0.0", + "-rpcallowip=0.0.0.0/0", + "-bind=0.0.0.0", + "-listen=1", + "-whitelist=0.0.0.0/0", + "-txindex=1", + "-fallbackfee=0.0002", + "-dbcache=16", + "-maxmempool=16" + ] + <> case kind of + -- releases of Bitcoin Cash Node stop serving RPC some months + -- after they come out unless told not to + BitcoinCashNode -> ["-expire=0"] + BitcoinCore -> [], + ports = [18443, 18444] + } + +-- | Error returned by a node. +data RpcError = RpcError !Text !Value + deriving (Show) + +instance Exception RpcError + +-- | Call a method of the node and return its result. +rpc :: Node -> Text -> [Value] -> IO Value +rpc node method params = do + let opts = + Wreq.defaults + & Wreq.auth ?~ Wreq.basicAuth "test" "test" + & Wreq.checkResponse ?~ (\_ _ -> return ()) + body = + object + [ "jsonrpc" .= ("1.0" :: Text), + "id" .= ("test" :: Text), + "method" .= method, + "params" .= params + ] + r <- Wreq.postWith opts node.url body + case eitherDecode (r ^. Wreq.responseBody) of + Left e -> fail ("Bad answer to " <> T.unpack method <> ": " <> e) + Right v -> case (field "error" v, field "result" v) of + (Just Null, Just x) -> return x + (Nothing, Just x) -> return x + (Just e, _) -> throwIO (RpcError method e) + _ -> fail ("No result in answer to " <> T.unpack method) + +-- | Wait until the node answers RPC calls, for up to 90 seconds. +waitRpc :: Node -> IO () +waitRpc node = go (360 :: Int) + where + go n = + tryAny (rpc node "getblockchaininfo" []) >>= \case + Right _ -> return () + Left e + | n <= 0 -> fail ("The node did not start: " <> show e) + | otherwise -> threadDelay 250000 >> go (n - 1) + +-- | Make sure the node has exactly one wallet loaded, so that wallet calls +-- need no wallet name. Bitcoin Cash Node loads a default wallet; Bitcoin Core +-- has none until one is created. +ensureWallet :: Node -> IO () +ensureWallet node = + rpc node "listwallets" [] >>= \case + Array ws | not (null ws) -> return () + _ -> void $ rpc node "createwallet" [String "test"] + +-- | Field of a JSON object. +field :: Text -> Value -> Maybe Value +field k (Object o) = KeyMap.lookup (Key.fromText k) o +field _ _ = Nothing + +-- | Text field of a JSON object. +textField :: Text -> Value -> Maybe Text +textField k v = case field k v of + Just (String t) -> Just t + _ -> Nothing + +-- | Amount in satoshi as a JSON number of coins. +btc :: Word64 -> Value +btc s = Number (fromIntegral s / 100000000) + +-- | JSON number of coins in satoshi. +sats :: Value -> Word64 +sats (Number n) = round (n * 100000000) +sats v = error ("Not an amount: " <> show v) + +asText :: Value -> IO Text +asText (String t) = return t +asText v = fail ("Expected text, got " <> show v) + +-- | New address of the wallet of the node. +getNewAddress :: Node -> IO Text +getNewAddress node = rpc node "getnewaddress" [] >>= asText + +-- | Mine blocks paying to an address. Returns their hashes. +generateTo :: Node -> Int -> Text -> IO [Text] +generateTo node n addr = + rpc node "generatetoaddress" [Number (fromIntegral n), String addr] >>= \case + Array hs -> mapM asText (toList hs) + v -> fail ("Unexpected answer to generatetoaddress: " <> show v) + +-- | Send from the wallet of the node to an address. Returns the transaction +-- hash. +sendTo :: Node -> Text -> Word64 -> IO Text +sendTo node addr amount = + rpc node "sendtoaddress" [String addr, btc amount] >>= asText + +-- | Send from the wallet of the node to several addresses in one +-- transaction. Returns the transaction hash. +sendMany :: Node -> [(Text, Word64)] -> IO Text +sendMany node outs = + rpc node "sendmany" [String "", object [Key.fromText a .= btc v | (a, v) <- outs]] + >>= asText + +-- | Decoded transaction. +getRawTx :: Node -> Text -> IO Value +getRawTx node txid = rpc node "getrawtransaction" [String txid, Bool True] + +-- | Hash of the best block. +bestBlockHash :: Node -> IO Text +bestBlockHash node = rpc node "getbestblockhash" [] >>= asText + +-- | Hashes of the transactions in the mempool. +rawMempool :: Node -> IO [Text] +rawMempool node = + rpc node "getrawmempool" [] >>= \case + Array ts -> mapM asText (toList ts) + v -> fail ("Unexpected answer to getrawmempool: " <> show v) diff --git a/integration/Haskoin/Store/Integration/Podman.hs b/integration/Haskoin/Store/Integration/Podman.hs new file mode 100644 --- /dev/null +++ b/integration/Haskoin/Store/Integration/Podman.hs @@ -0,0 +1,190 @@ +-- | +-- Module : Haskoin.Store.Integration.Podman +-- Copyright : (c) Haskoin Developers +-- License : MIT +-- Maintainer : jprupp@protonmail.ch +-- Stability : experimental +-- Portability : POSIX +-- +-- Containers for the integration tests, run with Podman. +-- +-- The integration tests need real nodes and a real Redis, which are easiest +-- to get, at pinned versions and without installing anything, as container +-- images. Podman runs them without a daemon and without root, so a developer +-- or a CI runner can use it as it is. +-- +-- Everything is kept off the disk and cleaned up: +-- +-- * containers run with @--rm@ and are removed with @podman rm --force@ when +-- the test that started them ends, even if it fails; +-- * the volumes that images declare are mounted as tmpfs +-- (@--image-volume tmpfs@), and data directories are tmpfs mounts of +-- limited size; +-- * every container has a memory limit; +-- * containers carry a label with the process ID of the test run, and +-- containers left by a test run that was killed (whose process is gone) are +-- removed before new ones start. +-- +-- Ports are published on random ports of the loopback interface, so several +-- test runs can share a machine. +module Haskoin.Store.Integration.Podman + ( podmanUsable, + ContainerSpec (..), + Container (..), + withContainer, + hostPort, + withRamDir, + ) +where + +import Control.Monad (forM_, unless, void) +import Data.Aeson qualified as A +import Data.Aeson.Key qualified as Key +import Data.Aeson.KeyMap qualified as KeyMap +import Data.ByteString.Char8 qualified as C8 +import Data.ByteString.Lazy qualified as BL +import Data.Char (isDigit, isSpace) +import Data.List (dropWhileEnd) +import Data.Text qualified as T +import System.Environment (lookupEnv) +import System.Exit (ExitCode (..)) +import System.IO (hPutStrLn, stderr) +import System.Process (getCurrentPid, readProcessWithExitCode) +import UnliftIO (bracket, onException, timeout, tryAny) +import UnliftIO.Directory (doesDirectoryExist, doesPathExist, getTemporaryDirectory) +import UnliftIO.Temporary (withTempDirectory) + +-- | Whether Podman can run containers here, or why not. Set +-- @HASKOIN_STORE_NO_PODMAN@ to a value other than @0@ to skip the tests that +-- need it. +podmanUsable :: IO (Either String ()) +podmanUsable = do + skip <- lookupEnv "HASKOIN_STORE_NO_PODMAN" + case skip of + Just v | v `notElem` ["", "0"] -> return (Left "HASKOIN_STORE_NO_PODMAN is set") + _ -> do + r <- + tryAny . timeout (60 * 1000 * 1000) $ + readProcessWithExitCode "podman" ["info", "--format", "{{.Host.Arch}}"] "" + -- containers left by a test run that was killed are removed before + -- anything else, even if this run fails before starting any + case r of + Right (Just (ExitSuccess, _, _)) -> removeStale + _ -> return () + return $ case r of + Left e -> Left ("Podman is not available: " <> show e) + Right Nothing -> Left "podman info did not answer within a minute" + Right (Just (ExitSuccess, _, _)) -> Right () + Right (Just (_, _, err)) -> Left ("Podman cannot run containers: " <> trim err) + +-- | What to run. +data ContainerSpec = ContainerSpec + { -- | short name, part of the container name + name :: !String, + -- | image, with a pinned tag + image :: !String, + -- | options of @podman run@, such as memory limits and tmpfs mounts + options :: ![String], + -- | command and arguments, after the image + command :: ![String], + -- | TCP ports to publish on random ports of 127.0.0.1 + ports :: ![Int] + } + +-- | A running container. +data Container = Container + { -- | container ID + cid :: !String, + -- | container name + name :: !String + } + +-- | Label on every container started by the tests. Its value is the process +-- ID of the test run. +testLabel :: String +testLabel = "haskoin-store-test" + +-- | Run a container while an action runs, and remove it afterwards. If the +-- action throws, the last lines of the log of the container are printed to +-- help find out why. +withContainer :: ContainerSpec -> (Container -> IO a) -> IO a +withContainer spec act = do + removeStale + pid <- show <$> getCurrentPid + let cname = testLabel <> "-" <> pid <> "-" <> spec.name + args = + ["run", "--detach", "--rm", "--name", cname] + <> ["--label", testLabel <> "=" <> pid, "--image-volume", "tmpfs"] + <> spec.options + <> concatMap (\p -> ["--publish", "127.0.0.1::" <> show p]) spec.ports + <> [spec.image] + <> spec.command + bracket (start cname args) stop $ \c -> act c `onException` logs c + where + start cname args = do + (code, out, err) <- readProcessWithExitCode "podman" args "" + case code of + ExitSuccess -> return Container {cid = trim out, name = cname} + _ -> do + -- a container may exist even though the command failed + void $ readProcessWithExitCode "podman" ["rm", "--force", cname] "" + fail ("podman run " <> spec.image <> " failed: " <> trim err) + stop :: Container -> IO () + stop c = + void $ readProcessWithExitCode "podman" ["rm", "--force", "--time", "2", c.cid] "" + logs :: Container -> IO () + logs c = do + (_, out, err) <- readProcessWithExitCode "podman" ["logs", "--tail", "40", c.cid] "" + hPutStrLn stderr $ "--- last lines of the log of " <> c.name <> " ---\n" <> out <> err + +-- | Remove the containers of test runs whose process is gone. The list +-- comes as JSON: the Go templates of @podman ps@ cannot index the labels in +-- every version of Podman. +removeStale :: IO () +removeStale = do + (code, out, _) <- + readProcessWithExitCode + "podman" + ["ps", "--all", "--filter", "label=" <> testLabel, "--format", "json"] + "" + case (code, A.decode (BL.fromStrict (C8.pack out))) of + (ExitSuccess, Just cs) -> + forM_ (cs :: [A.Value]) $ \c -> case staleOf c of + Just (cid, pid) | all isDigit pid -> do + alive <- doesPathExist ("/proc/" <> pid) + unless alive . void $ readProcessWithExitCode "podman" ["rm", "--force", cid] "" + _ -> return () + _ -> return () + where + staleOf c = do + A.Object o <- Just c + A.String cid <- KeyMap.lookup "Id" o + A.Object labels <- KeyMap.lookup "Labels" o + A.String pid <- KeyMap.lookup (Key.fromString testLabel) labels + return (T.unpack cid, T.unpack pid) + +-- | Port of the host where a port of a container is published. +hostPort :: Container -> Int -> IO Int +hostPort c p = do + (code, out, err) <- readProcessWithExitCode "podman" ["port", c.cid, show p <> "/tcp"] "" + case (code, lines out) of + (ExitSuccess, l : _) + | [(n, "")] <- reads (reverse (takeWhile (/= ':') (reverse (trim l)))) -> + return n + _ -> fail ("Cannot find the published port " <> show p <> " of " <> c.name <> ": " <> trim err) + +trim :: String -> String +trim = dropWhileEnd isSpace . dropWhile isSpace + +-- | A temporary directory in memory: under @/dev/shm@ if there is one, else +-- under @$XDG_RUNTIME_DIR@, else the usual temporary directory. +withRamDir :: (FilePath -> IO a) -> IO a +withRamDir f = do + shm <- doesDirectoryExist "/dev/shm" + xdg <- lookupEnv "XDG_RUNTIME_DIR" + tmp <- getTemporaryDirectory + let base + | shm = "/dev/shm" + | Just x <- xdg = x + | otherwise = tmp + withTempDirectory base "haskoin-store-test" f diff --git a/integration/Haskoin/Store/Integration/Valkey.hs b/integration/Haskoin/Store/Integration/Valkey.hs new file mode 100644 --- /dev/null +++ b/integration/Haskoin/Store/Integration/Valkey.hs @@ -0,0 +1,57 @@ +-- | +-- Module : Haskoin.Store.Integration.Valkey +-- Copyright : (c) Haskoin Developers +-- License : MIT +-- Maintainer : jprupp@protonmail.ch +-- Stability : experimental +-- Portability : POSIX +-- +-- A Redis server for the integration tests and the stress test: Valkey, the +-- Redis-compatible server that Ubuntu ships, from the test image. +module Haskoin.Store.Integration.Valkey + ( redisContainer, + waitRedis, + ) +where + +import Database.Redis qualified as Redis +import Haskoin.Store.Integration.Image (valkeyBin) +import Haskoin.Store.Integration.Podman (ContainerSpec (..)) +import UnliftIO (bracket, tryAny) +import UnliftIO.Concurrent (threadDelay) + +-- | Valkey, the Redis-compatible server of Ubuntu, from the test image, listening on every interface of the container +-- (only its published port is reachable, on 127.0.0.1), with nothing saved +-- to disk and at most 128 MiB of data. +redisContainer :: String -> ContainerSpec +redisContainer image = + ContainerSpec + { name = "redis", + image = image, + options = ["--memory", "256m", "--entrypoint", valkeyBin], + command = + [ "--bind", + "0.0.0.0", + "--protected-mode", + "no", + "--save", + "", + "--appendonly", + "no", + "--maxmemory", + "128mb" + ], + ports = [6379] + } + +-- | Wait until Redis answers, for up to 30 seconds. +waitRedis :: String -> IO () +waitRedis url = go (120 :: Int) + where + info = either error id (Redis.parseConnectInfo url) + go n = + tryAny (bracket (Redis.checkedConnect info) Redis.disconnect (const (return ()))) >>= \case + Right () -> return () + Left e + | n <= 0 -> fail ("Redis did not start: " <> show e) + | otherwise -> threadDelay 250000 >> go (n - 1) diff --git a/src/Haskoin/Store.hs b/src/Haskoin/Store.hs --- a/src/Haskoin/Store.hs +++ b/src/Haskoin/Store.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE DuplicateRecordFields #-} - -- | -- Module : Haskoin.Store -- Copyright : (c) Haskoin Developers @@ -14,33 +12,49 @@ -- , downloads -- blocks and mempool transactions, and indexes them in RocksDB. The indices -- answer questions about blocks, transactions, address balances, unspent --- outputs and extended public keys. An optional Redis cache speeds up queries --- about extended public keys with many addresses. A REST API built on these --- indices is in "Haskoin.Store.Web". +-- outputs and extended public keys. A REST API built on these indices is in +-- "Haskoin.Store.Web". (The Redis cache of extended public keys is being +-- rewritten; until it is back, every query reads the database.) -- -- = Running a store -- --- 'withStore' starts everything from a 'StoreConfig': the database, the node, --- the block store that imports data, and the cache if configured. The 'Store' --- it returns has a 'DatabaseReader' and, if the cache is on, a 'CacheConfig'. --- Run queries with 'withDB', or inside 'withCache' to use the cache. +-- 'withStore' starts everything from a 'StoreConfig': the database, the node +-- and the block store that imports data. The 'Store' it returns has a +-- 'DatabaseReader'; query it with the functions of +-- "Haskoin.Store.Database.Query", which take the reader and run in 'IO'. -- -- @ -- 'withStore' cfg $ \\store -> --- 'withSubscription' store.pub $ \\events -> do --- best <- 'withDB' store.db 'getBestBlock' +-- withSubscription store.pub $ \\events -> do +-- best <- Haskoin.Store.Database.Query.getBestBlock store.db -- ... -- @ -- -- = Modules -- -- * "Haskoin.Store.Data": types of the data returned by the store and the API. --- * "Haskoin.Store.Common": the 'StoreReadBase' and 'StoreReadExtra' query --- interfaces. --- * "Haskoin.Store.Database.Reader": queries against RocksDB. +-- * "Haskoin.Store.Common": helpers for paging, ordering and deriving +-- addresses, and 'StoreRead', the queries of a store as a record of +-- functions in 'IO'. +-- * "Haskoin.Store.Database.Reader": opening the RocksDB database. +-- * "Haskoin.Store.Database.Query": queries against RocksDB, as plain +-- functions. +-- * "Haskoin.Store.Database.Mempool", "Haskoin.Store.Database.Migrate", +-- "Haskoin.Store.Logic.Layered" and +-- "Haskoin.Store.Database.Query.Layered": a layout of the database in +-- which the mempool is kept apart from the chain, the migration to it, the +-- rules that import blocks and transactions in it, and its queries. The +-- store does not use them yet; see @docs\/layered-database.md@. +-- * "Haskoin.Store.Fleet": how stores that share a Redis agree on the block +-- that they all answer from, as pure decisions, and +-- "Haskoin.Store.Fleet.Redis", which carries them out. +-- "Haskoin.Store.Fleet.Pool" has the rules of the mempool that they share. +-- Nothing uses them yet. +-- * "Haskoin.Store.Database.Views": the database as it was at each recent +-- block, for a store that answers from the block its fleet agrees on. +-- Nothing uses it yet. -- * "Haskoin.Store.BlockStore": the process that imports blocks and -- transactions. --- * "Haskoin.Store.Cache": the Redis cache for extended public keys. -- * "Haskoin.Store.Web": the REST API server. -- = Purpose -- @@ -64,9 +78,11 @@ -- query is a seek and a short scan, newest first; see -- "Haskoin.Store.Database.Types". -- --- * __One query interface, several back ends.__ The database, the import buffer --- and the Redis cache all implement 'StoreReadBase' and 'StoreReadExtra', so --- the same query code runs against any of them. +-- * __Plain functions in 'IO'.__ Queries take the database reader, or a +-- 'StoreRead' record of them, which the web server builds with the Redis +-- cache in front of the queries about xpubs. Nothing runs in a stack of +-- monad transformers, except the conduits that merge sorted streams. The +-- web server runs on WAI with a router of its own. -- -- * __The mempool is a first-class citizen.__ Unconfirmed transactions are indexed -- like confirmed ones, ordered before them, and kept across restarts, because @@ -84,16 +100,15 @@ module Haskoin.Store.Data, -- * Cache + Cache, CacheConfig (..), - CacheT, - CacheError (..), - withCache, - connectRedis, - isInCache, + cacheIsCached, + cacheDelete, + cacheEvict, -- * Store Reader - StoreReadBase (..), - StoreReadExtra (..), + StoreRead (..), + databaseRead, Limits (..), Start (..), @@ -110,6 +125,8 @@ import Haskoin.Store.Cache import Haskoin.Store.Common import Haskoin.Store.Data +-- the instances of the store classes for the database reader +import Haskoin.Store.Database.Query (databaseRead) import Haskoin.Store.Database.Reader import Haskoin.Store.Database.Types import Haskoin.Store.Manager diff --git a/src/Haskoin/Store/BlockStore.hs b/src/Haskoin/Store/BlockStore.hs --- a/src/Haskoin/Store/BlockStore.hs +++ b/src/Haskoin/Store/BlockStore.hs @@ -1,1502 +1,1221 @@ {-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ImportQualifiedPost #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedRecordDot #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE NoFieldSelectors #-} -{-# OPTIONS_GHC -Wno-ambiguous-fields #-} - --- | --- Module : Haskoin.Store.BlockStore --- Copyright : (c) Haskoin Developers --- License : MIT --- Maintainer : jprupp@protonmail.ch --- Stability : experimental --- Portability : POSIX --- --- The block store process downloads blocks and transactions from peers and --- imports them into the database. --- --- = Blocks --- --- When the best header of the node is ahead of the best block in the database, --- the block store picks one online peer as its syncing peer and asks it for --- blocks in batches of 'blockWindow'. Each block is imported as soon as it --- arrives. If the best block of the database is no longer in the main chain of --- headers, blocks are reverted until it is. A syncing peer that sends a block --- that was not requested, cannot find a block, or stays silent for longer than --- 'peerTimeout' is disconnected. --- --- = Mempool --- --- Once the database is in sync, the block store asks each peer for its mempool --- (if 'syncMempool' is set) and requests every transaction that peers --- announce. Received transactions are queued and imported in batches on every --- clock tick, in dependency order. Transactions that spend unknown outputs are --- kept for up to an hour, waiting for their parents. Mempool transactions older --- than 'mempoolTimeout' days are deleted. --- --- = Feeding the block store --- --- The block store does not listen to the node by itself. --- "Haskoin.Store.Manager" forwards node events to it with the --- @blockStore*@ functions of this module. --- = Why it works this way --- --- * __Blocks come from one peer at a time.__ Blocks must be imported in order, --- so downloading from several peers at once would only buffer blocks that cannot --- be imported yet. One syncing peer, kept busy with a sliding window of --- requests, uses the network well without unbounded buffering. --- --- * __The window refills early.__ The next batch is requested when fewer than a --- quarter of the window are still outstanding, so the peer never sits idle --- while the store imports, and the backlog never grows much beyond one window. --- --- * __Mempool sync waits for the tip.__ Unconfirmed transactions only make sense --- against the current chain, so they are requested once the database is in --- sync. --- --- * __Orphans get a grace period.__ A transaction can arrive before its parent. --- It is held for up to an hour, waiting for the parent, instead of being --- dropped and requested again. --- --- * __Imports are batched.__ Mempool transactions are imported up to 2000 at a --- time on each clock tick, which amortises the cost of a database write over --- many transactions during bursts. -module Haskoin.Store.BlockStore - ( -- * Block Store - BlockStore, - BlockStoreConfig (..), - withBlockStore, - blockStorePeerConnect, - blockStorePeerConnectSTM, - blockStorePeerDisconnect, - blockStorePeerDisconnectSTM, - blockStoreHead, - blockStoreHeadSTM, - blockStoreBlock, - blockStoreBlockSTM, - blockStoreNotFound, - blockStoreNotFoundSTM, - blockStoreTx, - blockStoreTxSTM, - blockStoreTxHash, - blockStoreTxHashSTM, - blockStorePendingTxs, - blockStorePendingTxsSTM, - needsMoreBlocks, - ) -where - -import Control.Monad - ( forM, - forM_, - mzero, - unless, - void, - when, - ) -import Control.Monad.Reader - ( MonadReader, - ReaderT (..), - ask, - asks, - ) -import Control.Monad.Trans (lift) -import Control.Monad.Trans.Maybe (MaybeT (MaybeT), runMaybeT) -import Data.Bool (bool) -import Data.ByteString qualified as B -import Data.HashMap.Strict (HashMap) -import Data.HashMap.Strict qualified as HashMap -import Data.HashSet (HashSet) -import Data.HashSet qualified as HashSet -import Data.List (delete) -import Data.Maybe - ( catMaybes, - fromJust, - fromMaybe, - isJust, - mapMaybe, - ) -import Data.Serialize (encode) -import Data.String (fromString) -import Data.String.Conversions (cs) -import Data.Text (Text) -import Data.Text qualified as T -import Data.Time.Clock - ( NominalDiffTime, - UTCTime, - diffUTCTime, - getCurrentTime, - ) -import Data.Time.Clock.POSIX - ( getPOSIXTime, - posixSecondsToUTCTime, - utcTimeToPOSIXSeconds, - ) -import Data.Time.Format - ( defaultTimeLocale, - formatTime, - ) -import Haskoin - ( Block (..), - BlockHash (..), - BlockHeader (..), - BlockHeight, - BlockNode (..), - Ctx, - GetData (..), - InvType (..), - InvVector (..), - Message (..), - Network (..), - OutPoint (..), - Tx (..), - TxHash (..), - TxIn (..), - blockHashToHex, - headerHash, - txHash, - txHashToHex, - ) -import Haskoin.Node - ( Chain, - LogLevel (..), - Logger, - OnlinePeer (..), - Peer (..), - PeerMgr, - chainBlockMain, - chainGetAncestor, - chainGetBest, - chainGetBlock, - chainGetParents, - getPeers, - killPeer, - logAt, - sendMessage, - setBusy, - setFree, - ) -import Haskoin.Store.Common -import Haskoin.Store.Data -import Haskoin.Store.Database.Reader -import Haskoin.Store.Database.Writer -import Haskoin.Store.Logic - ( ImportException (Orphan), - ImportM, - deleteUnconfirmedTx, - importBlock, - initBest, - newMempoolTx, - revertBlock, - ) -import NQE - ( InChan, - Listen, - Mailbox, - Publisher, - inboxToMailbox, - newInbox, - publish, - query, - receive, - send, - sendSTM, - ) -import System.Metrics.StatsD -import System.Random (randomRIO) -import UnliftIO - ( Exception, - MonadIO, - MonadUnliftIO, - STM, - TVar, - async, - atomically, - catch, - liftIO, - link, - modifyTVar, - modifyTVar', - newTVarIO, - readTVar, - readTVarIO, - throwIO, - try, - withAsync, - writeTVar, - ) -import UnliftIO.Concurrent (threadDelay) - --- | Messages handled by the block store process. -data BlockStoreMessage - = -- | the node has a new best header - BlockNewBest !BlockNode - | -- | a peer connected - BlockPeerConnect !Peer - | -- | a peer disconnected - BlockPeerDisconnect !Peer - | -- | a peer sent a block - BlockReceived !Peer !Block - | -- | a peer could not find blocks - BlockNotFound !Peer ![BlockHash] - | -- | a peer sent a transaction - TxRefReceived !Peer !Tx - | -- | a peer announced transactions - TxRefAvailable !Peer ![TxHash] - | -- | clock tick for housekeeping; reply when done - BlockPing !(Listen ()) - --- | Fatal errors of the block store. -data BlockException - = -- | the header of a block in the database is not known to the node - BlockNotInChain !BlockHash - | -- | the database has no best block - Uninitialized - | -- | the database is inconsistent - CorruptDatabase - | -- | the node has no header at this height below this block - AncestorNotInChain !BlockHeight !BlockHash - | -- | importing mempool transactions failed - MempoolImportFailed - deriving (Show, Eq, Ord, Exception) - --- | State of the sync against the syncing peer. -data Syncing = Syncing - { -- | peer that blocks are downloaded from - peer :: !Peer, - -- | when it last delivered a block, or when syncing started - time :: !UTCTime, - -- | blocks requested and not yet imported, in chain order - blocks :: ![BlockHash] - } - --- | Transaction received from a peer and waiting to be imported. -data PendingTx = PendingTx - { -- | when it was received - time :: !UTCTime, - -- | the transaction - tx :: !Tx, - -- | parent transactions that are missing; empty if it can be imported - deps :: !(HashSet TxHash) - } - deriving (Show, Eq, Ord) - --- | Block store process state. -data BlockStore = BlockStore - { -- | mailbox of the process - mailbox :: !(Mailbox BlockStoreMessage), - -- | configuration - config :: !BlockStoreConfig, - -- | syncing peer, if any - peer :: !(TVar (Maybe Syncing)), - -- | transactions received and waiting to be imported - txs :: !(TVar (HashMap TxHash PendingTx)), - -- | transactions requested from peers in the last twenty seconds - requested :: !(TVar (HashSet TxHash)), - -- | StatsD metrics, if enabled - metrics :: !(Maybe StoreMetrics), - -- | labels of the peers whose mempool was already requested - syncedMempool :: !(TVar (HashSet Text)) - } - --- | StatsD metrics of the block store. -data StoreMetrics = StoreMetrics - { -- | height of the best block (@store.blocks@) - blocks :: !StatGauge, - -- | height of the best header (@store.headers@) - headers :: !StatGauge, - -- | transactions waiting to be imported (@store.queued_txs@) - queuedTxs :: !StatGauge, - -- | online peers (@store.peers@) - peers :: !StatGauge, - -- | transactions in the mempool (@store.mempool@) - mempool :: !StatGauge, - -- | milliseconds to import a block (@store.block@) - block :: !StatTiming - } - --- | Register the block store metrics, if StatsD is configured, with their current values. -newStoreMetrics :: (MonadIO m) => BlockStoreConfig -> m (Maybe StoreMetrics) -newStoreMetrics cfg = - forM cfg.stats $ \s -> liftIO $ do - m <- withDB cfg.db getMempool - b <- - fmap (maybe 0 (.height)) $ - withDB cfg.db $ - runMaybeT $ - MaybeT getBestBlock >>= MaybeT . getBlock - h <- chainGetBest cfg.chain - p <- getPeers cfg.peerMgr - blocks <- g s "blocks" (fromIntegral b) - headers <- g s "headers" (fromIntegral h.height) - queuedTxs <- g s "queued_txs" 0 - peers <- g s "peers" (length p) - mempool <- g s "mempool" (length m) - block <- t s "block" 0 - return StoreMetrics {..} - where - g s x = newStatGauge s ("store." <> x) - t s x = newStatTiming s ("store." <> x) - --- | Update the gauge of the best block height. -setStoreHeight :: (MonadIO m) => BlockT m () -setStoreHeight = void $ runMaybeT $ do - m <- MaybeT (asks (.metrics)) - h <- MaybeT getBestBlock - b <- MaybeT (getBlock h) - setGauge m.blocks (fromIntegral b.height) - --- | Update the gauge of the best header height. -setHeadersHeight :: (MonadIO m) => BlockT m () -setHeadersHeight = void $ runMaybeT $ do - m <- MaybeT (asks (.metrics)) - n <- liftIO . chainGetBest =<< asks (.config.chain) - setGauge m.headers (fromIntegral n.height) - --- | Update the gauge of transactions waiting to be imported. -setPendingTxs :: (MonadIO m) => BlockT m () -setPendingTxs = void $ runMaybeT $ do - m <- MaybeT (asks (.metrics)) - p <- readTVarIO =<< asks (.txs) - setGauge m.queuedTxs (HashMap.size p) - --- | Update the gauge of online peers. -setPeersConnected :: (MonadIO m) => BlockT m () -setPeersConnected = void $ runMaybeT $ do - m <- MaybeT (asks (.metrics)) - p <- liftIO . getPeers =<< asks (.config.peerMgr) - setGauge m.peers (length p) - --- | Record how long a successful block import took. -withBlockTiming :: (MonadIO m) => BlockT m (Either l r) -> BlockT m (Either l r) -withBlockTiming go = do - asks (.metrics) >>= \case - Just m -> do - start <- round . (* 1000) <$> liftIO getPOSIXTime - go >>= \case - Right x -> do - end <- round . (* 1000) <$> liftIO getPOSIXTime - addTiming m.block (end - start) - return (Right x) - Left y -> return (Left y) - Nothing -> go - --- | Configuration for a block store. -data BlockStoreConfig = BlockStoreConfig - { -- | secp256k1 context - ctx :: !Ctx, - -- | peer manager from running node - peerMgr :: !PeerMgr, - -- | chain from a running node - chain :: !Chain, - -- | listener for store events - pub :: !(Publisher StoreEvent), - -- | RocksDB database handle - db :: !DatabaseReader, - -- | network constants - net :: !Network, - -- | do not index new mempool transactions - noMempool :: !Bool, - -- | wipe mempool at start - wipeMempool :: !Bool, - -- | sync mempool from peers - syncMempool :: !Bool, - -- | blocks to request from the syncing peer in one batch - blockWindow :: !Int, - -- | delete transactions older than this number of days from mempool - mempoolTimeout :: !Int, - -- | disconnect syncing peer if inactive for this long - peerTimeout :: !NominalDiffTime, - -- | StatsD client, if metrics are enabled - stats :: !(Maybe Stats), - -- | log messages here - logger :: !Logger - } - --- | Monad transformer of the block store process. -type BlockT m = ReaderT BlockStore m - --- | Log a message with the logger of the block store. -logDebug, logInfo, logWarn, logError :: - (MonadIO m, MonadReader BlockStore m) => Text -> m () -logDebug = blockLog LevelDebug -logInfo = blockLog LevelInfo -logWarn = blockLog LevelWarn -logError = blockLog LevelError - --- | Log a message at a level with the logger of the block store. -blockLog :: (MonadIO m, MonadReader BlockStore m) => LogLevel -> Text -> m () -blockLog l msg = asks (.config.logger) >>= \lg -> logAt l lg msg - --- | Run an import against the database, returning the import error if it fails. -runImport :: - (MonadIO m) => - Network -> - Ctx -> - ImportM a -> - BlockT m (Either ImportException a) -runImport net ctx f = fmap fst <$> runImportMempool net ctx f - --- | Like 'runImport', but also return how the import changed the mempool. --- The mempool gauge is kept up to date from those changes instead of --- counting the whole mempool on every clock tick. -runImportMempool :: - (MonadIO m) => - Network -> - Ctx -> - ImportM a -> - BlockT m (Either ImportException (a, MempoolChanges)) -runImportMempool net ctx f = do - r <- ReaderT $ \r -> - liftIO . try $ runWriterMempool net ctx r.config.db r.config.logger f - forM_ r $ \(_, c) -> asks (.metrics) >>= mapM_ (\m -> do - incrementGauge m.mempool (length c.added) - decrementGauge m.mempool (length c.removed)) - return r - --- | Run an import and publish the transactions that it added to the --- mempool or removed from it, then the new best block if there is one. --- Transactions of the block are not published. -runImportNotify :: - (MonadIO m) => - Maybe Block -> - ImportM a -> - BlockT m (Either ImportException a) -runImportNotify block f = do - net <- getNetwork - ctx <- getCtx - runImportMempool net ctx f >>= \case - Left e -> return (Left e) - Right (x, c) -> do - l <- asks (.config.pub) - forM_ (filter notInBlock c.removed) $ \h -> - publish (StoreMempoolDelete h) l - forM_ (filter notInBlock c.added) $ \h -> - publish (StoreMempoolNew h) l - forM_ block $ \b -> - publish (StoreBestBlock (headerHash b.header)) l - return (Right x) - where - inBlock = maybe HashSet.empty (HashSet.fromList . map txHash . (.txs)) block - notInBlock = not . (`HashSet.member` inBlock) - --- | Run a database query from the block store. -runRocksDB :: ReaderT DatabaseReader m a -> BlockT m a -runRocksDB f = - ReaderT $ runReaderT f . (.config.db) - -instance (MonadIO m) => StoreReadBase (BlockT m) where - getCtx = - asks (.config.ctx) - getNetwork = - runRocksDB getNetwork - getBestBlock = - runRocksDB getBestBlock - getBlocksAtHeight = - runRocksDB . getBlocksAtHeight - getBlock = - runRocksDB . getBlock - getTxData = - runRocksDB . getTxData - getManyTxData = - runRocksDB . getManyTxData - getSpender = - runRocksDB . getSpender - getUnspent = - runRocksDB . getUnspent - getBalance = - runRocksDB . getBalance - getMempool = - runRocksDB getMempool - getMempoolPage = - runRocksDB . getMempoolPage - -instance (MonadUnliftIO m) => StoreReadExtra (BlockT m) where - getMaxGap = - runRocksDB getMaxGap - getInitialGap = - runRocksDB getInitialGap - getAddressesTxs as = - runRocksDB . getAddressesTxs as - getAddressesUnspents as = - runRocksDB . getAddressesUnspents as - getAddressUnspents a = - runRocksDB . getAddressUnspents a - getAddressTxs a = - runRocksDB . getAddressTxs a - getNumTxData = - runRocksDB . getNumTxData - getBalances = - runRocksDB . getBalances - xPubBals = - runRocksDB . xPubBals - xPubUnspents x l = - runRocksDB . xPubUnspents x l - xPubTxs x l = - runRocksDB . xPubTxs x l - xPubTxCount x = - runRocksDB . xPubTxCount x - --- | Run block store process. -withBlockStore :: - (MonadUnliftIO m) => - BlockStoreConfig -> - (BlockStore -> m a) -> - m a -withBlockStore cfg action = do - pb <- newTVarIO Nothing - ts <- newTVarIO HashMap.empty - rq <- newTVarIO HashSet.empty - sy <- newTVarIO HashSet.empty - inbox <- newInbox - metrics <- newStoreMetrics cfg - let r = - BlockStore - { mailbox = inboxToMailbox inbox, - config = cfg, - peer = pb, - txs = ts, - requested = rq, - metrics = metrics, - syncedMempool = sy - } - withAsync (runReaderT (go inbox) r) $ \a -> do - link a - action r - where - go inbox = do - ini - wipe - run inbox - del txs = do - logAt LevelInfo cfg.logger $ - "Deleting " <> cs (show (length txs)) <> " transactions" - forM_ txs $ \(_, th) -> deleteUnconfirmedTx False th - wipe_it txs = do - net <- getNetwork - ctx <- getCtx - let (txs1, txs2) = splitAt 1000 txs - unless (null txs1) $ - runImport net ctx (del txs1) >>= \case - Left e -> do - logError $ - "Could not wipe mempool: " <> cs (show e) - throwIO e - Right () -> wipe_it txs2 - wipe - | cfg.wipeMempool = - getMempool >>= wipe_it - | otherwise = - return () - ini = do - net <- getNetwork - ctx <- getCtx - runImport net ctx initBest >>= \case - Left e -> do - logError $ - "Could not initialize: " <> cs (show e) - throwIO e - Right () -> return () - run inbox = - withAsync (pingMe (inboxToMailbox inbox)) $ \a -> - link a >> runBlockStoreLoop inbox - --- | Handle messages forever. -runBlockStoreLoop :: - (InChan mbox, MonadUnliftIO m) => - mbox BlockStoreMessage -> - ReaderT BlockStore m b -runBlockStoreLoop inbox = - loopForever $ do - logDebug "Waiting for new event..." - msg <- receive inbox - ReaderT $ runReaderT $ processBlockStoreMessage msg - --- | Whether the best block in the database is the best header of the node. If --- so, release the syncing peer. -isInSync :: (MonadIO m) => BlockT m Bool -isInSync = - getBestBlock >>= \case - Nothing -> do - logError "Block database uninitialized" - throwIO Uninitialized - Just bb -> do - cb <- asks (.config.chain) >>= liftIO . chainGetBest - if headerHash cb.header == bb - then clearSyncingState >> return True - else return False - --- | Run an action only if the database is in sync. -guardSync :: (MonadIO m) => BlockT m () -> BlockT m () -guardSync f = isInSync >>= \s -> when s f - --- | Run an action only if the mempool is indexed. -guardMempool :: (Monad m) => BlockT m () -> BlockT m () -guardMempool f = asks (.config.noMempool) >>= \n -> unless n f - --- | Ask a peer for its mempool, once per peer, if in sync and mempool sync is enabled. -syncMempool :: (MonadUnliftIO m) => Peer -> BlockT m () -syncMempool p = - guardMempool . guardSync $ do - s <- asks (.config.syncMempool) - m <- asks (.syncedMempool) - y <- not . HashSet.member p.label <$> readTVarIO m - when (s && y) $ do - logDebug $ - "Requesting mempool from peer: " <> p.label - atomically . modifyTVar m $ HashSet.insert p.label - liftIO $ MMempool `sendMessage` p - --- | Import a block from the syncing peer, then ask for more blocks or, if now in --- sync, sync the mempool. Disconnects the peer if it is not the syncing peer, if --- the block is unknown to the node, or if the block cannot be imported. -processBlock :: - (MonadUnliftIO m) => - Peer -> - Block -> - BlockT m () -processBlock peer block = void . runMaybeT $ do - checkPeer peer >>= \case - True -> return () - False -> do - logError $ - "Non-syncing peer " - <> peer.label - <> " sent block " - <> blockHashToHex blockhash - killPeer peer - mzero - node <- - getBlockNode blockhash >>= \case - Just b -> return b - Nothing -> do - logError $ - "Peer " - <> peer.label - <> " sent unknown block " - <> blockHashToHex blockhash - killPeer peer - mzero - logDebug $ - "Processing block " - <> blockText node Nothing - <> " from peer " - <> peer.label - lift $ do - ret <- withBlockTiming $ runImportNotify (Just block) (importBlock block node) - case ret of - Left e -> failure e - Right _ -> success node - where - header = block.header - blockhash = headerHash header - hexhash = blockHashToHex blockhash - success node = do - logInfo $ - "Best block: " <> blockText node (Just block) - removeSyncingBlock $ headerHash node.header - touchPeer - isInSync >>= \case - False -> syncMe - True -> do - updateOrphans - syncMempool peer - failure e = do - logError $ - "Error importing block " - <> hexhash - <> " from peer: " - <> peer.label - <> ": " - <> cs (show e) - killPeer peer - --- | Set the blocks requested from the syncing peer. -setSyncingBlocks :: - (MonadReader BlockStore m, MonadIO m) => - [BlockHash] -> - m () -setSyncingBlocks hs = - asks (.peer) >>= \box -> - atomically $ - modifyTVar box $ \case - Nothing -> Nothing - Just x -> Just (x :: Syncing) {blocks = hs} - --- | Blocks requested from the syncing peer and not yet imported. -getSyncingBlocks :: (MonadReader BlockStore m, MonadIO m) => m [BlockHash] -getSyncingBlocks = - asks (.peer) >>= readTVarIO >>= \case - Nothing -> return [] - Just x -> return x.blocks - --- | Add blocks to those requested from the syncing peer. -addSyncingBlocks :: - (MonadReader BlockStore m, MonadIO m) => - [BlockHash] -> - m () -addSyncingBlocks hs = - asks (.peer) >>= \box -> - atomically $ - modifyTVar box $ \case - Nothing -> Nothing - Just x -> Just (x :: Syncing) {blocks = x.blocks <> hs} - --- | Remove a block from those requested from the syncing peer. -removeSyncingBlock :: - (MonadReader BlockStore m, MonadIO m) => - BlockHash -> - m () -removeSyncingBlock h = do - box <- asks (.peer) - atomically $ - modifyTVar box $ \case - Nothing -> Nothing - Just x -> Just (x :: Syncing) {blocks = delete h x.blocks} - --- | Whether a peer is the syncing peer. -checkPeer :: (MonadIO m, MonadReader BlockStore m) => Peer -> m Bool -checkPeer p = fmap (fromMaybe False) <$> runMaybeT $ do - Syncing {peer} <- MaybeT getSyncingState - return $ peer == p - --- | Header of a block from the node. -getBlockNode :: - (MonadIO m, MonadReader BlockStore m) => - BlockHash -> - m (Maybe BlockNode) -getBlockNode blockhash = do - ch <- asks (.config.chain) - liftIO $ chainGetBlock ch blockhash - --- | Disconnect a peer that could not find requested blocks. -processNoBlocks :: - (MonadIO m) => - Peer -> - [BlockHash] -> - BlockT m () -processNoBlocks p hs = do - forM_ (zip [(1 :: Int) ..] hs) $ \(i, h) -> - logError $ - "Block " - <> cs (show i) - <> "/" - <> cs (show (length hs)) - <> " " - <> blockHashToHex h - <> " not found by peer: " - <> p.label - killPeer p - --- | Queue a transaction received from a peer for import. -processTx :: (MonadIO m) => Peer -> Tx -> BlockT m () -processTx p tx = guardMempool $ do - t <- liftIO getCurrentTime - logDebug $ - "Received tx " - <> txHashToHex (txHash tx) - <> " by peer: " - <> p.label - addPendingTx $ PendingTx t tx HashSet.empty - --- | Drop queued transactions received more than an hour ago. -pruneOrphans :: (MonadIO m) => BlockT m () -pruneOrphans = guardMempool $ do - ts <- asks (.txs) - now <- liftIO getCurrentTime - -- keep pending transactions received within the last hour, drop older ones - atomically . modifyTVar' ts . HashMap.filter $ \p -> - now `diffUTCTime` p.time <= 3600 - --- | Queue a transaction for import. -addPendingTx :: (MonadIO m) => PendingTx -> BlockT m () -addPendingTx p = do - ts <- asks (.txs) - rq <- asks (.requested) - atomically $ do - modifyTVar ts $ HashMap.insert th p - modifyTVar rq $ HashSet.delete th - setPendingTxs - where - th = txHash p.tx - --- | Remember for twenty seconds that a transaction was requested, so that it is not requested again. -addRequestedTx :: (MonadIO m) => TxHash -> BlockT m () -addRequestedTx th = do - qbox <- asks (.requested) - atomically $ modifyTVar qbox $ HashSet.insert th - liftIO . void . async $ do - threadDelay 20000000 - atomically $ modifyTVar qbox $ HashSet.delete th - --- | Whether a transaction is queued or was requested recently. -isPending :: (MonadIO m) => TxHash -> BlockT m Bool -isPending th = do - tbox <- asks (.txs) - qbox <- asks (.requested) - atomically $ do - ts <- readTVar tbox - rs <- readTVar qbox - return $ - th `HashMap.member` ts - || th `HashSet.member` rs - --- | Take up to this many queued transactions that have no missing parents, in --- dependency order, out of the queue. -pendingTxs :: (MonadIO m) => Int -> BlockT m [PendingTx] -pendingTxs i = do - selected <- - asks (.txs) >>= \box -> atomically $ do - pending <- readTVar box - let (selected, rest) = select pending - writeTVar box rest - return selected - setPendingTxs - return selected - where - select pend = - let eligible = HashMap.filter (null . (.deps)) pend - orphans = HashMap.difference pend eligible - selected = take i $ sortit eligible - remaining = HashMap.filter (`notElem` selected) eligible - in (selected, remaining <> orphans) - sortit m = - let sorted = sortTxs $ map (.tx) $ HashMap.elems m - txids = map (txHash . snd) sorted - in mapMaybe (`HashMap.lookup` m) txids - --- | Mark a transaction as no longer missing for the queued transactions that spend it. -fulfillOrphans :: (MonadIO m) => BlockStore -> TxHash -> m () -fulfillOrphans block_read th = - atomically $ modifyTVar box (HashMap.map fulfill) - where - box = block_read.txs - fulfill p = p {deps = HashSet.delete th p.deps} - --- | Drop queued transactions that are already in the database, and recompute the --- missing parents of the others. -updateOrphans :: - ( StoreReadBase m, - MonadIO m, - MonadReader BlockStore m - ) => - m () -updateOrphans = do - box <- asks (.txs) - pending <- readTVarIO box - let orphans = HashMap.filter (not . null . (.deps)) pending - updated <- forM orphans $ \p -> do - let tx = p.tx - exists (txHash tx) >>= \case - True -> return Nothing - False -> Just <$> fill_deps p - let pruned = HashMap.map fromJust $ HashMap.filter isJust updated - atomically $ writeTVar box pruned - where - exists th = - getTxData th >>= \case - Nothing -> return False - Just TxData {deleted = True} -> return False - Just TxData {deleted = False} -> return True - prev_utxos tx = catMaybes <$> mapM (getUnspent . (.outpoint)) tx.inputs - fulfill p unspent = - let unspent_hash = unspent.outpoint.hash - new_deps = HashSet.delete unspent_hash p.deps - in p {deps = new_deps} - fill_deps p = do - let tx = p.tx - unspents <- prev_utxos tx - return $ foldl fulfill p unspents - --- | Queue a transaction that spends unknown outputs, recording which parents are missing. -newOrphanTx :: - (MonadIO m) => - BlockStore -> - UTCTime -> - Tx -> - WriterT m () -newOrphanTx block_read time tx = do - logAt LevelDebug block_read.config.logger $ - "Import tx " - <> txHashToHex (txHash tx) - <> ": Orphan" - let box = block_read.txs - unspents <- catMaybes <$> mapM getUnspent prevs - let unspent_set = HashSet.fromList (map (.outpoint) unspents) - missing_set = HashSet.difference prev_set unspent_set - missing_txs = HashSet.map (.hash) missing_set - atomically . modifyTVar box $ - HashMap.insert - (txHash tx) - PendingTx - { time = time, - tx = tx, - deps = missing_txs - } - where - prev_set = HashSet.fromList prevs - prevs = map (.outpoint) tx.inputs - --- | Import a transaction into the mempool. Returns 'True' if imported. A --- transaction that spends unknown outputs is queued as an orphan; other errors --- are ignored. -importMempoolTx :: BlockStore -> UTCTime -> Tx -> ImportM Bool -importMempoolTx block_read time tx = - catch new_mempool_tx handle_error - where - tx_hash = txHash tx - handle_error :: ImportException -> ImportM Bool - handle_error Orphan = do - newOrphanTx block_read time tx - return False - handle_error _ = return False - seconds = floor (utcTimeToPOSIXSeconds time) - new_mempool_tx = do - t <- newMempoolTx tx seconds - logAt LevelInfo block_read.config.logger $ - bool "Already have" "Imported" t - <> " tx " - <> txHashToHex (txHash tx) - when t $ fulfillOrphans block_read tx_hash - return t - --- | Import up to 2000 queued transactions. -processMempool :: (MonadIO m) => BlockT m () -processMempool = guardMempool $ do - txs <- pendingTxs 2000 - block_read <- ask - unless (null txs) $ import_txs block_read txs - where - run_import block_read p = - importMempoolTx block_read p.time p.tx - import_txs block_read txs = - runImportNotify Nothing (mapM (run_import block_read) txs) >>= \case - Left e -> report_error e - Right _ -> return () - report_error e = do - logError $ - "Error processing mempool: " <> cs (show e) - throwIO e - --- | Delete up to 1000 mempool transactions older than the configured number of days. -pruneMempool :: (MonadIO m) => BlockT m () -pruneMempool = - guardMempool $ do - days <- asks (.config.mempoolTimeout) - when (days > 0) $ do - time <- (floor . utcTimeToPOSIXSeconds) <$> liftIO getCurrentTime - let thresh = time - (fromIntegral days * 24 * 60 * 60) - -- runs on every clock tick: read only the expired entries, oldest - -- first, from the index by time - txs <- map snd <$> runRocksDB (getMempoolBefore thresh 1000) - unless (null txs) $ do - logInfo $ - "Deleting " <> cs (show (length txs)) <> " old transactions from mempool" - runImportNotify Nothing (mapM_ (deleteUnconfirmedTx False) txs) >>= \case - Left e -> - logError $ - "Error pruning mempool: " <> cs (show e) - Right () -> return () - --- | Request from a peer the announced transactions that are neither queued, --- recently requested nor in the database. Only while in sync. -processTxs :: - (MonadIO m) => - Peer -> - [TxHash] -> - BlockT m () -processTxs p hs = guardMempool . guardSync $ do - logDebug $ - "Received inventory with " - <> cs (show (length hs)) - <> " transactions from peer: " - <> p.label - xs <- catMaybes <$> zip_counter process_tx - unless (null xs) $ go xs - where - len = length hs - zip_counter = forM (zip [(1 :: Int) ..] hs) . uncurry - process_tx i h = - isPending h >>= \case - True -> do - logDebug $ - "Tx " - <> cs (show i) - <> "/" - <> cs (show len) - <> " " - <> txHashToHex h - <> ": " - <> "Already Pending" - return Nothing - False -> - getTxData h >>= \case - Just _ -> do - logDebug $ - "Tx " - <> cs (show i) - <> "/" - <> cs (show len) - <> " " - <> txHashToHex h - <> ": " - <> "Already Imported" - return Nothing - Nothing -> do - logDebug $ - "Tx " - <> cs (show i) - <> "/" - <> cs (show len) - <> " " - <> txHashToHex h - <> ": " - <> "Requesting" - return (Just h) - go xs = do - mapM_ addRequestedTx xs - net <- asks (.config.net) - let inv = if net.segWit then InvWitnessTx else InvTx - vec = map (InvVector inv . (.get)) xs - msg = MGetData (GetData vec) - liftIO $ msg `sendMessage` p - --- | Record that the syncing peer just delivered something. -touchPeer :: - ( MonadIO m, - MonadReader BlockStore m - ) => - m () -touchPeer = - getSyncingState >>= \case - Nothing -> return () - Just _ -> do - box <- asks (.peer) - now <- liftIO getCurrentTime - atomically $ - modifyTVar box $ - fmap $ - \x -> (x :: Syncing) {time = now} - --- | Disconnect the syncing peer if it has been silent for too long. -checkTime :: (MonadIO m) => BlockT m () -checkTime = - asks (.peer) >>= readTVarIO >>= \case - Nothing -> return () - Just - Syncing - { time = t, - peer = p - } -> do - now <- liftIO getCurrentTime - peer_time_out <- asks (.config.peerTimeout) - when (now `diffUTCTime` t > peer_time_out) $ do - logError $ - "Syncing peer timeout: " <> p.label - killPeer p - --- | Revert blocks until the best block in the database is in the main chain of headers. -revertToMainChain :: (MonadIO m) => BlockT m () -revertToMainChain = do - h <- headerHash . (.header) <$> getBest - ch <- asks (.config.chain) - net <- getNetwork - ctx <- getCtx - liftIO (chainBlockMain ch h) >>= \x -> unless x $ do - logWarn $ - "Reverting best block: " - <> blockHashToHex h - runImport net ctx (revertBlock h) >>= \case - Left e -> do - logError $ - "Could not revert block " - <> blockHashToHex h - <> ": " - <> cs (show e) - throwIO e - Right () -> setSyncingBlocks [] - revertToMainChain - --- | Header of the best block in the database. -getBest :: (MonadIO m) => BlockT m BlockNode -getBest = do - bb <- - getBestBlock >>= \case - Just b -> return b - Nothing -> do - logError "No best block set" - throwIO Uninitialized - ch <- asks (.config.chain) - liftIO (chainGetBlock ch bb) >>= \case - Just x -> return x - Nothing -> do - logError $ - "Header not found for best block: " - <> blockHashToHex bb - throwIO (BlockNotInChain bb) - --- | Header of the last block requested from the syncing peer, or of the best block if none. -getSyncBest :: (MonadIO m) => BlockT m BlockNode -getSyncBest = do - bb <- - getSyncingBlocks >>= \case - [] -> - getBestBlock >>= \case - Just b -> return b - Nothing -> do - logError "No best block set" - throwIO Uninitialized - hs -> return $ last hs - ch <- asks (.config.chain) - liftIO (chainGetBlock ch bb) >>= \case - Just x -> return x - Nothing -> do - logError $ - "Header not found for block: " - <> blockHashToHex bb - throwIO (BlockNotInChain bb) - --- | The syncing peer, when it is time to ask it for the next batch of blocks. -shouldSync :: (MonadIO m) => BlockT m (Maybe Peer) -shouldSync = - isInSync >>= \case - True -> return Nothing - False -> - getSyncingState >>= \case - Nothing -> return Nothing - Just Syncing {peer = p, blocks = bs} -> do - window <- blockWindow - return $ - if needsMoreBlocks window (length bs) - then Just p - else Nothing - --- | Blocks to request from the syncing peer in one batch. Never below one, --- or the store would never ask for any block. -blockWindow :: (Monad m) => BlockT m Int -blockWindow = asks (max 1 . (.config.blockWindow)) - --- | Whether to ask for the next batch, given the window size and how many --- requested blocks are still waiting to be imported. Asking once fewer than --- a quarter of the window remain keeps the peer busy, while the queue of --- downloaded blocks never grows much beyond one window. The threshold is at --- least one, so that a window smaller than four still refills once empty. -needsMoreBlocks :: Int -> Int -> Bool -needsMoreBlocks window outstanding = - outstanding < max 1 (window `div` 4) - --- | Ask the syncing peer for the next batch of blocks, if the window has room. -syncMe :: (MonadIO m) => BlockT m () -syncMe = do - revertToMainChain - shouldSync >>= \case - Nothing -> return () - Just p -> do - bb <- getSyncBest - bh <- getbh - when (bb /= bh) $ do - bns <- sel bb bh - iv <- getiv bns - logDebug $ - "Requesting " - <> fromString (show (length iv)) - <> " blocks from peer: " - <> p.label - addSyncingBlocks $ map (headerHash . (.header)) bns - liftIO $ MGetData (GetData iv) `sendMessage` p - where - getiv bns = do - w <- asks (.config.net.segWit) - let i = if w then InvWitnessBlock else InvBlock - f = InvVector i . (.get) . headerHash . (.header) - return $ map f bns - getbh = - liftIO . chainGetBest =<< asks (.config.chain) - -- The blocks right after the last requested one, up to one window or - -- the chain tip, whichever comes first. - sel bb bh = do - window <- blockWindow - top <- findAncestor (min (bb.height + fromIntegral window) bh.height) bh - ch <- asks (.config.chain) - ps <- liftIO $ chainGetParents ch (bb.height + 1) top - return $ ps <> [top] - --- | Ancestor of a header at a height. Throws 'AncestorNotInChain' if missing. -findAncestor :: - (MonadIO m, MonadReader BlockStore m) => - BlockHeight -> - BlockNode -> - m BlockNode -findAncestor height target = do - ch <- asks (.config.chain) - liftIO (chainGetAncestor ch height target) >>= \case - Just ancestor -> return ancestor - Nothing -> do - let h = headerHash target.header - logError $ - "Could not find header for ancestor of block " - <> blockHashToHex h - <> " at height " - <> cs (show target.height) - throwIO $ AncestorNotInChain height h - --- | Forget a peer: release it if it was the syncing peer, and forget that its mempool was requested. -finishPeer :: - (MonadIO m, MonadReader BlockStore m) => - Peer -> - m () -finishPeer p = do - box <- asks (.peer) - readTVarIO box >>= \case - Just Syncing {peer = p'} | p == p' -> reset_it box - _ -> return () - y <- asks (.syncedMempool) - atomically $ modifyTVar y $ HashSet.delete p.label - where - reset_it box = do - atomically $ writeTVar box Nothing - logDebug $ "Releasing peer: " <> p.label - liftIO $ setFree p - --- | Make a peer the syncing peer if there is none and the peer is not busy. -trySetPeer :: (MonadIO m) => Peer -> BlockT m Bool -trySetPeer p = - getSyncingState >>= \case - Just _ -> return False - Nothing -> set_it - where - set_it = - liftIO (setBusy p) >>= \case - False -> return False - True -> do - logDebug $ - "Locked peer: " <> p.label - box <- asks (.peer) - now <- liftIO getCurrentTime - atomically . writeTVar box $ - Just - Syncing - { peer = p, - time = now, - blocks = [] - } - return True - --- | If not in sync and there is no syncing peer, pick the fastest free peer and start syncing. -trySyncing :: (MonadIO m) => BlockT m () -trySyncing = - isInSync >>= \case - True -> return () - False -> - getSyncingState >>= \case - Just _ -> return () - Nothing -> online_peer - where - recurse [] = return () - recurse (p : ps) = - trySetPeer p >>= \case - False -> recurse ps - True -> syncMe - online_peer = do - ops <- liftIO . getPeers =<< asks (.config.peerMgr) - let ps = map (.mailbox) ops - recurse ps - --- | Start syncing against a newly connected peer if needed, or request its mempool if in sync. -trySyncingPeer :: (MonadUnliftIO m) => Peer -> BlockT m () -trySyncingPeer p = - isInSync >>= \case - True -> syncMempool p - False -> - trySetPeer p >>= \case - False -> return () - True -> syncMe - --- | State of the sync against the syncing peer, if any. -getSyncingState :: - (MonadIO m, MonadReader BlockStore m) => m (Maybe Syncing) -getSyncingState = - readTVarIO =<< asks (.peer) - --- | Release the syncing peer, if any. -clearSyncingState :: - (MonadIO m, MonadReader BlockStore m) => m () -clearSyncingState = - asks (.peer) >>= readTVarIO >>= \case - Nothing -> return () - Just Syncing {peer = p} -> finishPeer p - --- | Handle a message sent to the block store. -processBlockStoreMessage :: - (MonadUnliftIO m) => - BlockStoreMessage -> - BlockT m () -processBlockStoreMessage (BlockNewBest node) = do - logDebug $ - "New best block mined at height " - <> cs (show node.height) - <> ": " - <> blockHashToHex (headerHash node.header) - trySyncing -processBlockStoreMessage (BlockPeerConnect p) = do - logDebug $ - "New peer connected: " <> p.label - trySyncingPeer p -processBlockStoreMessage (BlockPeerDisconnect p) = do - logDebug $ - "Peer disconnected: " <> p.label - finishPeer p -processBlockStoreMessage (BlockReceived p b) = do - logDebug $ - "Received block: " - <> blockHashToHex (headerHash b.header) - processBlock p b -processBlockStoreMessage (BlockNotFound p bs) = do - logDebug $ - "Blocks not found by peer " - <> p.label - <> ": " - <> T.unwords (map blockHashToHex bs) - processNoBlocks p bs -processBlockStoreMessage (TxRefReceived p tx) = do - logDebug $ - "Transaction received from peer " - <> p.label - <> ": " - <> txHashToHex (txHash tx) - processTx p tx -processBlockStoreMessage (TxRefAvailable p ts) = do - logDebug $ - "Transactions available from peer " - <> p.label - <> ": " - <> T.unwords (map txHashToHex ts) - processTxs p ts -processBlockStoreMessage (BlockPing r) = do - logDebug "Internal clock event" - setStoreHeight - setHeadersHeight - setPendingTxs - setPeersConnected - trySyncing - processMempool - pruneOrphans - pruneMempool - checkTime - atomically (r ()) - --- | Send a clock tick to the block store every 0.1 to 1 second, waiting for each to be handled. -pingMe :: (MonadIO m) => Mailbox BlockStoreMessage -> m () -pingMe mbox = - loopForever $ do - BlockPing `query` mbox - delay <- liftIO $ randomRIO (100 * 1000, 1000 * 1000) - threadDelay delay - --- | Tell the block store that a peer connected. -blockStorePeerConnect :: (MonadIO m) => Peer -> BlockStore -> m () -blockStorePeerConnect peer store = - BlockPeerConnect peer `send` store.mailbox - --- | Tell the block store that a peer disconnected. -blockStorePeerDisconnect :: - (MonadIO m) => Peer -> BlockStore -> m () -blockStorePeerDisconnect peer store = - BlockPeerDisconnect peer `send` store.mailbox - --- | Tell the block store that the node has a new best header. -blockStoreHead :: - (MonadIO m) => BlockNode -> BlockStore -> m () -blockStoreHead node store = - BlockNewBest node `send` store.mailbox - --- | Give the block store a block received from a peer. -blockStoreBlock :: - (MonadIO m) => Peer -> Block -> BlockStore -> m () -blockStoreBlock peer block store = - BlockReceived peer block `send` store.mailbox - --- | Tell the block store that a peer could not find blocks. -blockStoreNotFound :: - (MonadIO m) => Peer -> [BlockHash] -> BlockStore -> m () -blockStoreNotFound peer blocks store = - BlockNotFound peer blocks `send` store.mailbox - --- | Give the block store a transaction received from a peer. -blockStoreTx :: - (MonadIO m) => Peer -> Tx -> BlockStore -> m () -blockStoreTx peer tx store = - TxRefReceived peer tx `send` store.mailbox - --- | Tell the block store that a peer announced transactions. -blockStoreTxHash :: - (MonadIO m) => Peer -> [TxHash] -> BlockStore -> m () -blockStoreTxHash peer txhashes store = - TxRefAvailable peer txhashes `send` store.mailbox - --- | 'STM' version of 'blockStorePeerConnect'. -blockStorePeerConnectSTM :: - Peer -> BlockStore -> STM () -blockStorePeerConnectSTM peer store = - BlockPeerConnect peer `sendSTM` store.mailbox - --- | 'STM' version of 'blockStorePeerDisconnect'. -blockStorePeerDisconnectSTM :: - Peer -> BlockStore -> STM () -blockStorePeerDisconnectSTM peer store = - BlockPeerDisconnect peer `sendSTM` store.mailbox - --- | 'STM' version of 'blockStoreHead'. -blockStoreHeadSTM :: - BlockNode -> BlockStore -> STM () -blockStoreHeadSTM node store = - BlockNewBest node `sendSTM` store.mailbox - --- | 'STM' version of 'blockStoreBlock'. -blockStoreBlockSTM :: - Peer -> Block -> BlockStore -> STM () -blockStoreBlockSTM peer block store = - BlockReceived peer block `sendSTM` store.mailbox - --- | 'STM' version of 'blockStoreNotFound'. -blockStoreNotFoundSTM :: - Peer -> [BlockHash] -> BlockStore -> STM () -blockStoreNotFoundSTM peer blocks store = - BlockNotFound peer blocks `sendSTM` store.mailbox - --- | 'STM' version of 'blockStoreTx'. -blockStoreTxSTM :: - Peer -> Tx -> BlockStore -> STM () -blockStoreTxSTM peer tx store = - TxRefReceived peer tx `sendSTM` store.mailbox - --- | 'STM' version of 'blockStoreTxHash'. -blockStoreTxHashSTM :: - Peer -> [TxHash] -> BlockStore -> STM () -blockStoreTxHashSTM peer txhashes store = - TxRefAvailable peer txhashes `sendSTM` store.mailbox - --- | Number of transactions queued or requested by the block store. -blockStorePendingTxs :: - (MonadIO m) => BlockStore -> m Int -blockStorePendingTxs = - atomically . blockStorePendingTxsSTM - --- | 'STM' version of 'blockStorePendingTxs'. -blockStorePendingTxsSTM :: - BlockStore -> STM Int -blockStorePendingTxsSTM BlockStore {..} = do - x <- HashMap.keysSet <$> readTVar txs - y <- readTVar requested - return $ HashSet.size $ x `HashSet.union` y +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wno-ambiguous-fields #-} + +-- | +-- Module : Haskoin.Store.BlockStore +-- Copyright : (c) Haskoin Developers +-- License : MIT +-- Maintainer : jprupp@protonmail.ch +-- Stability : experimental +-- Portability : POSIX +-- +-- The block store process downloads blocks and transactions from peers and +-- imports them into the database. +-- +-- = Blocks +-- +-- When the best header of the node is ahead of the best block in the database, +-- the block store picks one online peer as its syncing peer and asks it for +-- blocks in batches of 'blockWindow'. Each block is imported as soon as it +-- arrives. If the best block of the database is no longer in the main chain of +-- headers, blocks are reverted until it is. A syncing peer that sends a block +-- that was not requested, cannot find a block, or stays silent for longer than +-- 'peerTimeout' is disconnected. The state of the download, and every rule +-- about it, is the pure state machine of "Haskoin.Store.BlockStore.Sync"; +-- this module carries out what its transitions decide. +-- +-- = Mempool +-- +-- Once the database is in sync, the block store asks each peer for its mempool +-- (if 'syncMempool' is set) and requests every transaction that peers +-- announce. Received transactions are queued and imported in batches on every +-- clock tick, in dependency order. Transactions that spend unknown outputs are +-- kept for up to an hour, waiting for their parents. Mempool transactions older +-- than 'mempoolTimeout' days are deleted. The transactions on their way in, +-- requested or received, are the pure value of +-- "Haskoin.Store.BlockStore.Pending". +-- +-- = Feeding the block store +-- +-- The block store does not listen to the node by itself. +-- "Haskoin.Store.Manager" forwards node events to it with the +-- @blockStore*@ functions of this module. +-- = Why it works this way +-- +-- * __Blocks come from one peer at a time.__ Blocks must be imported in order, +-- so downloading from several peers at once would only buffer blocks that cannot +-- be imported yet. One syncing peer, kept busy with a sliding window of +-- requests, uses the network well without unbounded buffering. +-- +-- * __The window refills early.__ The next batch is requested when fewer than a +-- quarter of the window are still outstanding, so the peer never sits idle +-- while the store imports, and the backlog never grows much beyond one window. +-- +-- * __Mempool sync waits for the tip.__ Unconfirmed transactions only make sense +-- against the current chain, so they are requested once the database is in +-- sync. +-- +-- * __Orphans get a grace period.__ A transaction can arrive before its parent. +-- It is held for up to an hour, waiting for the parent, instead of being +-- dropped and requested again. +-- +-- * __Imports are batched.__ Mempool transactions are imported up to 2000 at a +-- time on each clock tick, which amortises the cost of a database write over +-- many transactions during bursts. +module Haskoin.Store.BlockStore + ( -- * Block Store + BlockStore, + BlockStoreConfig (..), + withBlockStore, + blockStorePeerConnect, + blockStorePeerConnectSTM, + blockStorePeerDisconnect, + blockStorePeerDisconnectSTM, + blockStoreHead, + blockStoreHeadSTM, + blockStoreBlock, + blockStoreBlockSTM, + blockStoreNotFound, + blockStoreNotFoundSTM, + blockStoreTx, + blockStoreTxSTM, + blockStoreTxHash, + blockStoreTxHashSTM, + blockStorePendingTxs, + blockStorePendingTxsSTM, + needsMoreBlocks, + ) +where + +import Control.Monad + ( forM, + forM_, + unless, + void, + when, + (>=>), + ) +import Data.Bool (bool) +import Data.ByteString qualified as B +import Data.HashMap.Strict qualified as HashMap +import Data.HashSet (HashSet) +import Data.HashSet qualified as HashSet +import Data.Maybe + ( catMaybes, + isJust, + ) +import Data.Serialize (encode) +import Data.String (fromString) +import Data.String.Conversions (cs) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Time.Clock + ( NominalDiffTime, + UTCTime, + getCurrentTime, + ) +import Data.Time.Clock.POSIX + ( getPOSIXTime, + posixSecondsToUTCTime, + utcTimeToPOSIXSeconds, + ) +import Data.Time.Format + ( defaultTimeLocale, + formatTime, + ) +import Haskoin + ( Block (..), + BlockHash (..), + BlockHeader (..), + BlockHeight, + BlockNode (..), + Ctx, + GetData (..), + InvType (..), + InvVector (..), + Message (..), + Network (..), + OutPoint (..), + Tx (..), + TxHash (..), + TxIn (..), + blockHashToHex, + headerHash, + txHash, + txHashToHex, + ) +import Haskoin.Node + ( Chain, + LogLevel (..), + Logger, + OnlinePeer (..), + Owner, + Peer (..), + PeerMgr, + chainBlockMain, + chainGetAncestor, + chainGetBest, + chainGetBlock, + chainGetParents, + getPeers, + killPeer, + logAt, + newOwner, + releasePeer, + reservePeer, + sendMessage, + ) +import Haskoin.Store.BlockStore.Pending (Pending, PendingTx (..)) +import Haskoin.Store.BlockStore.Pending qualified as Pending +import Haskoin.Store.BlockStore.Sync + ( Accept (..), + Sync (..), + needsMoreBlocks, + ) +import Haskoin.Store.BlockStore.Sync qualified as Sync +import Haskoin.Store.Common (StoreEvent (..), loopForever) +import Haskoin.Store.Data +import Haskoin.Store.Database.Mempool (wipeMempoolArea) +import Haskoin.Store.Database.Query (getMempoolBefore) +import Haskoin.Store.Database.Query qualified as Q +import Haskoin.Store.Database.Query.Layered qualified as L +import Haskoin.Store.Database.Reader +import Haskoin.Store.Database.Writer (MempoolChanges (..), Writer, runWriterMempool) +import Haskoin.Store.Database.Writer qualified as W +import Haskoin.Store.Logic (ImportException (..)) +import Haskoin.Store.Logic.Layered + ( deleteUnconfirmedTx, + importBlock, + initBest, + newMempoolTx, + revertBlock, + ) +import NQE + ( InChan, + Listen, + Mailbox, + Publisher, + inboxToMailbox, + newInbox, + publish, + query, + receive, + send, + sendSTM, + ) +import System.Metrics.StatsD +import System.Random (randomRIO) +import UnliftIO + ( Exception, + STM, + TVar, + atomically, + catch, + link, + modifyTVar, + modifyTVar', + newTVarIO, + readTVar, + readTVarIO, + stateTVar, + throwIO, + try, + withAsync, + ) +import UnliftIO.Concurrent (threadDelay) + +-- | Messages handled by the block store process. +data BlockStoreMessage + = -- | the node has a new best header + BlockNewBest !BlockNode + | -- | a peer connected + BlockPeerConnect !Peer + | -- | a peer disconnected + BlockPeerDisconnect !Peer + | -- | a peer sent a block + BlockReceived !Peer !Block + | -- | a peer could not find blocks + BlockNotFound !Peer ![BlockHash] + | -- | a peer sent a transaction + TxRefReceived !Peer !Tx + | -- | a peer announced transactions + TxRefAvailable !Peer ![TxHash] + | -- | clock tick for housekeeping; reply when done + BlockPing !(Listen ()) + +-- | Fatal errors of the block store. +data BlockException + = -- | the header of a block in the database is not known to the node + BlockNotInChain !BlockHash + | -- | the database has no best block + Uninitialized + | -- | the database is inconsistent + CorruptDatabase + | -- | the node has no header at this height below this block + AncestorNotInChain !BlockHeight !BlockHash + | -- | importing mempool transactions failed + MempoolImportFailed + deriving (Show, Eq, Ord, Exception) + +-- | Block store process state. +data BlockStore = BlockStore + { -- | mailbox of the process + mailbox :: !(Mailbox BlockStoreMessage), + -- | configuration + config :: !BlockStoreConfig, + -- | state of the block download ("Haskoin.Store.BlockStore.Sync") + sync :: !(TVar (Sync Peer)), + -- | transactions received and waiting to be imported + -- ("Haskoin.Store.BlockStore.Pending") + pending :: !(TVar Pending), + -- | StatsD metrics, if enabled + metrics :: !(Maybe StoreMetrics), + -- | labels of the peers whose mempool was already requested + syncedMempool :: !(TVar (HashSet Text)), + -- | who reserves the syncing peer, so that no one else releases it + owner :: !Owner, + -- | transactions that left the mempool unconfirmed since the store + -- started, as many as 'mostForgotten'. The database keeps nothing of + -- them, and peers go on announcing them: without this the store would + -- fetch each one again, only to refuse it again. + forgotten :: !(TVar (HashSet TxHash)) + } + +-- | How many deleted transactions the store remembers not to fetch again. +-- Past that many it forgets them all and starts over, which costs a few +-- fetches that come to nothing. +mostForgotten :: Int +mostForgotten = 100000 + +-- | StatsD metrics of the block store. +data StoreMetrics = StoreMetrics + { -- | height of the best block (@store.blocks@) + blocks :: !StatGauge, + -- | height of the best header (@store.headers@) + headers :: !StatGauge, + -- | transactions waiting to be imported (@store.queued_txs@) + queuedTxs :: !StatGauge, + -- | online peers (@store.peers@) + peers :: !StatGauge, + -- | transactions in the mempool (@store.mempool@) + mempool :: !StatGauge, + -- | milliseconds to import a block (@store.block@) + block :: !StatTiming + } + +-- | Register the block store metrics, if StatsD is configured, with their current values. +newStoreMetrics :: BlockStoreConfig -> IO (Maybe StoreMetrics) +newStoreMetrics cfg = + forM cfg.stats $ \s -> do + m <- Q.getMempool cfg.db + b <- + Q.getBestBlock cfg.db >>= \case + Nothing -> return 0 + Just h -> maybe 0 (.height) <$> Q.getBlock cfg.db h + h <- chainGetBest cfg.chain + p <- getPeers cfg.peerMgr + blocks <- g s "blocks" (fromIntegral b) + headers <- g s "headers" (fromIntegral h.height) + queuedTxs <- g s "queued_txs" 0 + peers <- g s "peers" (length p) + mempool <- g s "mempool" (length m) + block <- t s "block" 0 + return StoreMetrics {..} + where + g s x = newStatGauge s ("store." <> x) + t s x = newStatTiming s ("store." <> x) + +-- | Update the gauge of the best block height. +setStoreHeight :: BlockStore -> IO () +setStoreHeight self = + forM_ self.metrics $ \m -> + getBestBlock self >>= mapM_ (getBlock self >=> mapM_ (setGauge m.blocks . fromIntegral . (.height))) + +-- | Update the gauge of the best header height. +setHeadersHeight :: BlockStore -> IO () +setHeadersHeight self = + forM_ self.metrics $ \m -> do + n <- chainGetBest self.config.chain + setGauge m.headers (fromIntegral n.height) + +-- | Update the gauge of transactions waiting to be imported. +setPendingTxs :: BlockStore -> IO () +setPendingTxs self = + forM_ self.metrics $ \m -> do + p <- readTVarIO self.pending + setGauge m.queuedTxs (Pending.queued p) + +-- | Update the gauge of online peers. +setPeersConnected :: BlockStore -> IO () +setPeersConnected self = + forM_ self.metrics $ \m -> do + p <- getPeers self.config.peerMgr + setGauge m.peers (length p) + +-- | Record how long a successful block import took. +withBlockTiming :: BlockStore -> IO (Either l r) -> IO (Either l r) +withBlockTiming self go = do + case self.metrics of + Just m -> do + start <- round . (* 1000) <$> getPOSIXTime + go >>= \case + Right x -> do + end <- round . (* 1000) <$> getPOSIXTime + addTiming m.block (end - start) + return (Right x) + Left y -> return (Left y) + Nothing -> go + +-- | Configuration for a block store. +data BlockStoreConfig = BlockStoreConfig + { -- | secp256k1 context + ctx :: !Ctx, + -- | peer manager from running node + peerMgr :: !PeerMgr, + -- | chain from a running node + chain :: !Chain, + -- | listener for store events + pub :: !(Publisher StoreEvent), + -- | RocksDB database handle + db :: !DatabaseReader, + -- | network constants + net :: !Network, + -- | do not index new mempool transactions + noMempool :: !Bool, + -- | wipe mempool at start + wipeMempool :: !Bool, + -- | what to do with the best block right after it changes, and when the + -- store starts, before anything else is written to the database: a + -- member of a fleet takes a view of the database for the block here + -- ('Haskoin.Store.Fleet.Member.noteBest') + onBest :: !(BlockHash -> IO ()), + -- | sync mempool from peers + syncMempool :: !Bool, + -- | blocks to request from the syncing peer in one batch + blockWindow :: !Int, + -- | delete transactions older than this number of days from mempool + mempoolTimeout :: !Int, + -- | disconnect syncing peer if inactive for this long + peerTimeout :: !NominalDiffTime, + -- | StatsD client, if metrics are enabled + stats :: !(Maybe Stats), + -- | log messages here + logger :: !Logger + } + +-- | Log a message with the logger of the block store. +logDebug, logInfo, logWarn, logError :: BlockStore -> Text -> IO () +logDebug self = logAt LevelDebug self.config.logger +logInfo self = logAt LevelInfo self.config.logger +logWarn self = logAt LevelWarn self.config.logger +logError self = logAt LevelError self.config.logger + +-- | Run an import against the database, returning the import error if it fails. +runImport :: BlockStore -> Network -> Ctx -> (Writer -> IO a) -> IO (Either ImportException a) +runImport self net ctx f = fmap fst <$> runImportMempool self net ctx f + +-- | Like 'runImport', but also return how the import changed the mempool. +-- The mempool gauge is kept up to date from those changes instead of +-- counting the whole mempool on every clock tick. +runImportMempool :: BlockStore -> Network -> Ctx -> (Writer -> IO a) -> IO (Either ImportException (a, MempoolChanges)) +runImportMempool self net ctx f = do + r <- try $ runWriterMempool net ctx self.config.db self.config.logger f + forM_ r $ \(_, c) -> + forM_ + self.metrics + ( \m -> do + incrementGauge m.mempool (length c.added) + decrementGauge m.mempool (length c.removed) + ) + return r + +-- | Run an import and publish the transactions that it added to the +-- mempool or removed from it, then the new best block if there is one. +-- Transactions of the block are not published. +runImportNotify :: BlockStore -> Maybe Block -> (Writer -> IO a) -> IO (Either ImportException a) +runImportNotify self block f = do + net <- getNetwork self + ctx <- getCtx self + runImportMempool self net ctx f >>= \case + Left e -> return (Left e) + Right (x, c) -> do + let l = self.config.pub + let deleted = filter notInBlock c.removed + atomically . modifyTVar' self.forgotten $ \seen -> + let more = foldr HashSet.insert seen deleted + in if HashSet.size more > mostForgotten then HashSet.fromList deleted else more + -- one that came back is not forgotten any more + atomically (modifyTVar' self.forgotten (\seen -> foldr HashSet.delete seen c.added)) + forM_ deleted $ \h -> + publish (StoreMempoolDelete h) l + forM_ (filter notInBlock c.added) $ \h -> + publish (StoreMempoolNew h) l + forM_ block $ \b -> do + -- before the event, so that whoever hears of the block finds what + -- was done for it + self.config.onBest (headerHash b.header) + publish (StoreBestBlock (headerHash b.header)) l + return (Right x) + where + inBlock = maybe HashSet.empty (HashSet.fromList . map txHash . (.txs)) block + notInBlock = not . (`HashSet.member` inBlock) + +-- | Run a database query from the block store. +-- | Best block in the database. +getBestBlock :: BlockStore -> IO (Maybe BlockHash) +getBestBlock self = Q.getBestBlock self.config.db + +-- | Data of a block in the database. +getBlock :: BlockStore -> BlockHash -> IO (Maybe BlockData) +getBlock self = Q.getBlock self.config.db + +-- | Data of a transaction in the database: confirmed, in the mempool, or +-- deleted from it and marked so. +getTxData :: BlockStore -> TxHash -> IO (Maybe TxData) +getTxData self h = L.withView self.config.db (`L.getTxData` h) + +-- | Unspent output in the database, of the chain or of the mempool. +getUnspent :: BlockStore -> OutPoint -> IO (Maybe Unspent) +getUnspent self p = L.withView self.config.db (`L.getUnspent` p) + +-- | Network of the block store. +getNetwork :: BlockStore -> IO Network +getNetwork self = return self.config.net + +-- | Secp256k1 context of the block store. +getCtx :: BlockStore -> IO Ctx +getCtx self = return self.config.ctx + +-- | Run block store process. +withBlockStore :: + BlockStoreConfig -> + (BlockStore -> IO a) -> + IO a +withBlockStore cfg action = do + pb <- newTVarIO Idle + ts <- newTVarIO Pending.empty + sy <- newTVarIO HashSet.empty + inbox <- newInbox + metrics <- newStoreMetrics cfg + owner <- (newOwner "block store") + forgotten <- newTVarIO HashSet.empty + let r = + BlockStore + { mailbox = inboxToMailbox inbox, + config = cfg, + sync = pb, + pending = ts, + metrics = metrics, + syncedMempool = sy, + owner = owner, + forgotten = forgotten + } + withAsync ((go r inbox)) $ \a -> do + link a + action r + where + go self inbox = do + ini + wipe + run + where + -- the mempool is an area of its own, so wiping it is deleting the + -- keys of that area: nothing of the chain has to be put right + wipe = when cfg.wipeMempool $ do + keys <- wipeMempoolArea cfg.db + forM_ self.metrics $ \m -> setGauge m.mempool 0 + logAt LevelInfo cfg.logger $ + "Wiped the mempool: " <> cs (show keys) <> " keys deleted" + ini = do + net <- getNetwork self + ctx <- getCtx self + runImport self net ctx initBest >>= \case + Left e -> do + logError self $ + "Could not initialize: " <> cs (show e) + throwIO e + Right () -> getBestBlock self >>= mapM_ cfg.onBest + run = + withAsync (pingMe (inboxToMailbox inbox)) $ \a -> + link a >> runBlockStoreLoop self inbox + +-- | Handle messages forever. +runBlockStoreLoop :: (InChan mbox) => BlockStore -> mbox BlockStoreMessage -> IO b +runBlockStoreLoop self inbox = + loopForever $ do + logDebug self "Waiting for new event..." + msg <- receive inbox + processBlockStoreMessage self msg + +-- | Whether the best block in the database is the best header of the node. If +-- so, release the syncing peer. +isInSync :: BlockStore -> IO Bool +isInSync self = + getBestBlock self >>= \case + Nothing -> do + logError self "Block database uninitialized" + throwIO Uninitialized + Just bb -> do + cb <- chainGetBest self.config.chain + if headerHash cb.header == bb + then clearSyncingState self >> return True + else return False + +-- | Run an action only if the database is in sync. +guardSync :: BlockStore -> IO () -> IO () +guardSync self f = isInSync self >>= \s -> when s f + +-- | Run an action only if the mempool is indexed. +guardMempool :: BlockStore -> IO () -> IO () +guardMempool self f = unless self.config.noMempool f + +-- | Ask a peer for its mempool, once per peer, if in sync and mempool sync is enabled. +syncMempool :: BlockStore -> Peer -> IO () +syncMempool self p = + guardMempool self . guardSync self $ do + let s = self.config.syncMempool + let m = self.syncedMempool + y <- not . HashSet.member p.label <$> readTVarIO m + when (s && y) $ do + logDebug self $ + "Requesting mempool from peer: " <> p.label + atomically . modifyTVar m $ HashSet.insert p.label + MMempool `sendMessage` p + +-- | Import a block from the syncing peer, then ask for more blocks or, if now in +-- sync, sync the mempool. Disconnects the peer if it is not the syncing peer, if +-- the block is unknown to the node, or if the block cannot be imported. +processBlock :: BlockStore -> Peer -> Block -> IO () +processBlock self peer block = + Sync.accept peer blockhash <$> readTVarIO self.sync >>= \case + NotSyncingPeer -> refuse "Non-syncing peer" + NotRequested -> refuse "Syncing peer" + Requested -> + getBlockNode self blockhash >>= \case + Nothing -> do + logError self $ + "Peer " + <> peer.label + <> " sent unknown block " + <> blockHashToHex blockhash + killPeer peer + Just node -> do + logDebug self $ + "Processing block " + <> blockText node Nothing + <> " from peer " + <> peer.label + ret <- withBlockTiming self $ runImportNotify self (Just block) (\wr -> importBlock wr block node) + case ret of + Left e -> failure e + Right _ -> success node + where + header = block.header + blockhash = headerHash header + hexhash = blockHashToHex blockhash + refuse who = do + logError self $ + who + <> " " + <> peer.label + <> " sent a block that was not requested: " + <> hexhash + killPeer peer + success node = do + logInfo self $ + "Best block: " <> blockText node (Just block) + now <- getCurrentTime + transition self $ \st -> ((), Sync.imported now blockhash st) + isInSync self >>= \case + False -> syncMe self + True -> do + updateOrphans self + syncMempool self peer + failure e = do + logError self $ + "Error importing block " + <> hexhash + <> " from peer: " + <> peer.label + <> ": " + <> cs (show e) + killPeer peer + +-- | Change the state of the block download with a transition of +-- "Haskoin.Store.BlockStore.Sync", atomically, and give its result. +transition :: BlockStore -> (Sync Peer -> (a, Sync Peer)) -> IO a +transition self = atomically . stateTVar self.sync + +-- | Header of a block from the node. +getBlockNode :: BlockStore -> BlockHash -> IO (Maybe BlockNode) +getBlockNode self blockhash = do + let ch = self.config.chain + chainGetBlock ch blockhash + +-- | Disconnect a peer that could not find requested blocks. +processNoBlocks :: BlockStore -> Peer -> [BlockHash] -> IO () +processNoBlocks self p hs = do + forM_ (zip [(1 :: Int) ..] hs) $ \(i, h) -> + logError self $ + "Block " + <> cs (show i) + <> "/" + <> cs (show (length hs)) + <> " " + <> blockHashToHex h + <> " not found by peer: " + <> p.label + killPeer p + +-- | Queue a transaction received from a peer for import. +processTx :: BlockStore -> Peer -> Tx -> IO () +processTx self p tx = guardMempool self $ do + t <- getCurrentTime + logDebug self $ + "Received tx " + <> txHashToHex (txHash tx) + <> " by peer: " + <> p.label + changePending self (Pending.received t tx HashSet.empty) + +-- | Forget old requests, and drop transactions that waited for their parents +-- for too long. +pruneOrphans :: BlockStore -> IO () +pruneOrphans self = guardMempool self $ do + now <- getCurrentTime + changePending self (Pending.prune now) + +-- | Change the mempool transactions on their way into the database. +changePending :: BlockStore -> (Pending -> Pending) -> IO () +changePending self f = do + atomically $ modifyTVar' self.pending f + setPendingTxs self + +-- | Whether a transaction is queued or was requested recently. +isPending :: BlockStore -> TxHash -> IO Bool +isPending self th = Pending.isPending th <$> readTVarIO self.pending + +-- | Take up to this many queued transactions that have no missing parents, in +-- dependency order, out of the queue. +pendingTxs :: BlockStore -> Int -> IO [PendingTx] +pendingTxs self i = do + selected <- atomically $ stateTVar self.pending (Pending.takeReady i) + setPendingTxs self + return selected + +-- | Drop queued transactions that are already in the database, and recompute the +-- missing parents of the others. +updateOrphans :: BlockStore -> IO () +updateOrphans self = do + orphans <- Pending.waiting <$> readTVarIO self.pending + updates <- forM orphans $ \p -> do + let h = txHash p.tx + exists h >>= \case + True -> return (h, Nothing) + False -> do + found <- catMaybes <$> mapM (getUnspent self . (.outpoint)) p.tx.inputs + let have = HashSet.fromList (map (.outpoint.hash) found) + return (h, Just (HashSet.difference p.deps have)) + changePending self (Pending.refresh (HashMap.fromList updates)) + where + exists th = + getTxData self th >>= \case + Nothing -> return False + Just TxData {deleted = True} -> return False + Just TxData {deleted = False} -> return True + +-- | Whether the store has a transaction, or deleted it not long ago: in +-- both cases there is nothing to fetch. +known :: BlockStore -> TxHash -> IO (Maybe ()) +known self h = + HashSet.member h <$> readTVarIO self.forgotten >>= \case + True -> return (Just ()) + False -> (() <$) <$> getTxData self h + +-- | Queue a transaction that spends unknown outputs, recording which parents are missing. +newOrphanTx :: + BlockStore -> + UTCTime -> + Tx -> + Writer -> + IO () +newOrphanTx self time tx wr = do + logAt LevelDebug self.config.logger $ + "Import tx " + <> txHashToHex (txHash tx) + <> ": Orphan" + unspents <- catMaybes <$> mapM (W.getUnspent wr) prevs + let have = HashSet.fromList (map (.outpoint) unspents) + missing = HashSet.map (.hash) (HashSet.difference (HashSet.fromList prevs) have) + atomically . modifyTVar' self.pending $ Pending.received time tx missing + where + prevs = map (.outpoint) tx.inputs + +-- | Import a transaction into the mempool. Returns 'True' if imported. A +-- transaction that spends unknown outputs is queued as an orphan; other errors +-- are ignored. +importMempoolTx :: BlockStore -> UTCTime -> Tx -> Writer -> IO Bool +importMempoolTx block_read time tx wr = + catch new_mempool_tx handle_error + where + tx_hash = txHash tx + handle_error :: ImportException -> IO Bool + handle_error Orphan = do + newOrphanTx block_read time tx wr + return False + handle_error _ = return False + seconds = floor (utcTimeToPOSIXSeconds time) + new_mempool_tx = do + t <- newMempoolTx wr tx seconds + logAt LevelInfo block_read.config.logger $ + bool "Already have" "Imported" t + <> " tx " + <> txHashToHex (txHash tx) + when t . atomically . modifyTVar' block_read.pending $ Pending.imported tx_hash + return t + +-- | Import up to 2000 queued transactions. +processMempool :: BlockStore -> IO () +processMempool self = guardMempool self $ do + txs <- pendingTxs self 2000 + let block_read = self + unless (null txs) $ import_txs block_read txs + where + run_import block_read wr p = + importMempoolTx block_read p.time p.tx wr + import_txs block_read txs = + runImportNotify self Nothing (\wr -> mapM (run_import block_read wr) txs) >>= \case + Left e -> report_error e + Right _ -> return () + report_error e = do + logError self $ + "Error processing mempool: " <> cs (show e) + throwIO e + +-- | Delete up to 1000 mempool transactions older than the configured number of days. +pruneMempool :: BlockStore -> IO () +pruneMempool self = + guardMempool self $ do + let days = self.config.mempoolTimeout + when (days > 0) $ do + time <- (floor . utcTimeToPOSIXSeconds) <$> getCurrentTime + let thresh = time - (fromIntegral days * 24 * 60 * 60) + -- runs on every clock tick: read only the expired entries, oldest + -- first, from the index by time + let db = self.config.db + txs <- map snd <$> (getMempoolBefore db thresh 1000) + unless (null txs) $ do + logInfo self $ + "Deleting " <> cs (show (length txs)) <> " old transactions from mempool" + runImportNotify self Nothing (\wr -> mapM_ (deleteUnconfirmedTx wr False) txs) >>= \case + Left e -> + logError self $ + "Error pruning mempool: " <> cs (show e) + Right () -> return () + +-- | Request from a peer the announced transactions that are neither queued, +-- recently requested nor in the database. Only while in sync. +processTxs :: BlockStore -> Peer -> [TxHash] -> IO () +processTxs self p hs = guardMempool self . guardSync self $ do + logDebug self $ + "Received inventory with " + <> cs (show (length hs)) + <> " transactions from peer: " + <> p.label + xs <- catMaybes <$> zip_counter process_tx + unless (null xs) $ go xs + where + len = length hs + zip_counter = forM (zip [(1 :: Int) ..] hs) . uncurry + process_tx i h = + isPending self h >>= \case + True -> do + logDebug self $ + "Tx " + <> cs (show i) + <> "/" + <> cs (show len) + <> " " + <> txHashToHex h + <> ": " + <> "Already Pending" + return Nothing + False -> + known self h >>= \case + Just _ -> do + logDebug self $ + "Tx " + <> cs (show i) + <> "/" + <> cs (show len) + <> " " + <> txHashToHex h + <> ": " + <> "Already Imported" + return Nothing + Nothing -> do + logDebug self $ + "Tx " + <> cs (show i) + <> "/" + <> cs (show len) + <> " " + <> txHashToHex h + <> ": " + <> "Requesting" + return (Just h) + go xs = do + now <- getCurrentTime + changePending self (Pending.requested now xs) + let net = self.config.net + let inv = if net.segWit then InvWitnessTx else InvTx + vec = map (InvVector inv . (.get)) xs + msg = MGetData (GetData vec) + msg `sendMessage` p + +-- | Disconnect the syncing peer if it has been silent for too long. +checkTime :: BlockStore -> IO () +checkTime self = do + now <- getCurrentTime + Sync.timedOut self.config.peerTimeout now <$> readTVarIO self.sync >>= \case + Nothing -> return () + Just p -> do + logError self $ "Syncing peer timeout: " <> p.label + killPeer p + +-- | Revert blocks until the best block in the database is in the main chain of headers. +revertToMainChain :: BlockStore -> IO () +revertToMainChain self = do + h <- headerHash . (.header) <$> getBest self + let ch = self.config.chain + net <- getNetwork self + ctx <- getCtx self + (chainBlockMain ch h) >>= \x -> unless x $ do + logWarn self $ + "Reverting best block: " + <> blockHashToHex h + runImport self net ctx (`revertBlock` h) >>= \case + Left e -> do + logError self $ + "Could not revert block " + <> blockHashToHex h + <> ": " + <> cs (show e) + throwIO e + Right () -> do + getBestBlock self >>= mapM_ self.config.onBest + transition self $ \st -> ((), Sync.forgetRequests st) + revertToMainChain self + +-- | Header of the best block in the database. +getBest :: BlockStore -> IO BlockNode +getBest self = do + bb <- + getBestBlock self >>= \case + Just b -> return b + Nothing -> do + logError self "No best block set" + throwIO Uninitialized + let ch = self.config.chain + (chainGetBlock ch bb) >>= \case + Just x -> return x + Nothing -> do + logError self $ + "Header not found for best block: " + <> blockHashToHex bb + throwIO (BlockNotInChain bb) + +-- | Header of the last block requested from the syncing peer, or of the best block if none. +getSyncBest :: BlockStore -> IO BlockNode +getSyncBest self = do + bb <- + Sync.lastRequested <$> readTVarIO self.sync >>= \case + Just h -> return h + Nothing -> + getBestBlock self >>= \case + Just b -> return b + Nothing -> do + logError self "No best block set" + throwIO Uninitialized + chainGetBlock self.config.chain bb >>= \case + Just x -> return x + Nothing -> do + logError self $ + "Header not found for block: " + <> blockHashToHex bb + throwIO (BlockNotInChain bb) + +-- | The syncing peer, when it is time to ask it for the next batch of blocks. +shouldSync :: BlockStore -> IO (Maybe Peer) +shouldSync self = + isInSync self >>= \case + True -> return Nothing + False -> Sync.wantsMore (blockWindow self) <$> readTVarIO self.sync + +-- | Blocks to request from the syncing peer in one batch. Never below one, +-- or the store would never ask for any block. +blockWindow :: BlockStore -> Int +blockWindow self = max 1 self.config.blockWindow + +-- | Ask the syncing peer for the next batch of blocks, if the window has room. +syncMe :: BlockStore -> IO () +syncMe self = do + revertToMainChain self + shouldSync self >>= \case + Nothing -> return () + Just p -> do + bb <- getSyncBest self + bh <- chainGetBest self.config.chain + when (bb /= bh) $ do + bns <- sel bb bh + logDebug self $ + "Requesting " + <> fromString (show (length bns)) + <> " blocks from peer: " + <> p.label + transition self $ \st -> ((), Sync.request (map (headerHash . (.header)) bns) st) + MGetData (GetData (map inv bns)) `sendMessage` p + where + inv = InvVector kind . (.get) . headerHash . (.header) + kind = if self.config.net.segWit then InvWitnessBlock else InvBlock + -- The blocks right after the last requested one, up to one window or + -- the chain tip, whichever comes first. + sel bb bh = do + top <- findAncestor self (min (bb.height + fromIntegral (blockWindow self)) bh.height) bh + ps <- chainGetParents self.config.chain (bb.height + 1) top + return $ ps <> [top] + +-- | Ancestor of a header at a height. Throws 'AncestorNotInChain' if missing. +findAncestor :: BlockStore -> BlockHeight -> BlockNode -> IO BlockNode +findAncestor self height target = do + let ch = self.config.chain + (chainGetAncestor ch height target) >>= \case + Just ancestor -> return ancestor + Nothing -> do + let h = headerHash target.header + logError self $ + "Could not find header for ancestor of block " + <> blockHashToHex h + <> " at height " + <> cs (show target.height) + throwIO $ AncestorNotInChain height h + +-- | Forget a peer: release it if it was the syncing peer, and forget that its mempool was requested. +finishPeer :: BlockStore -> Peer -> IO () +finishPeer self p = do + released <- transition self (Sync.release p) + when released $ do + logDebug self $ "Releasing peer: " <> p.label + void (releasePeer self.owner p) + atomically $ modifyTVar self.syncedMempool $ HashSet.delete p.label + +-- | Make a peer the syncing peer if there is none and the peer is not busy. +trySetPeer :: BlockStore -> Peer -> IO Bool +trySetPeer self p = + isJust . Sync.syncingPeer <$> readTVarIO self.sync >>= \case + True -> return False + False -> + reservePeer self.owner p >>= \case + False -> return False + True -> do + now <- getCurrentTime + started <- transition self $ \st -> case Sync.start now p st of + Just st' -> (True, st') + Nothing -> (False, st) + if started + then logDebug self ("Locked peer: " <> p.label) + else void (releasePeer self.owner p) + return started + +-- | If not in sync and there is no syncing peer, pick the first free peer and start syncing. +trySyncing :: BlockStore -> IO () +trySyncing self = + isInSync self >>= \case + True -> return () + False -> + isJust . Sync.syncingPeer <$> readTVarIO self.sync >>= \case + True -> return () + False -> getPeers self.config.peerMgr >>= recurse . map (.mailbox) + where + recurse [] = return () + recurse (p : ps) = + trySetPeer self p >>= \case + False -> recurse ps + True -> syncMe self + +-- | Start syncing against a newly connected peer if needed, or request its mempool if in sync. +trySyncingPeer :: BlockStore -> Peer -> IO () +trySyncingPeer self p = + isInSync self >>= \case + True -> syncMempool self p + False -> + trySetPeer self p >>= \case + False -> return () + True -> syncMe self + +-- | Release the syncing peer, if any. +clearSyncingState :: BlockStore -> IO () +clearSyncingState self = + Sync.syncingPeer <$> readTVarIO self.sync >>= mapM_ (finishPeer self) + +-- | Handle a message sent to the block store. +processBlockStoreMessage :: BlockStore -> BlockStoreMessage -> IO () +processBlockStoreMessage self (BlockNewBest node) = do + logDebug self $ + "New best block mined at height " + <> cs (show node.height) + <> ": " + <> blockHashToHex (headerHash node.header) + trySyncing self +processBlockStoreMessage self (BlockPeerConnect p) = do + logDebug self $ + "New peer connected: " <> p.label + trySyncingPeer self p +processBlockStoreMessage self (BlockPeerDisconnect p) = do + logDebug self $ + "Peer disconnected: " <> p.label + finishPeer self p +processBlockStoreMessage self (BlockReceived p b) = do + logDebug self $ + "Received block: " + <> blockHashToHex (headerHash b.header) + processBlock self p b +processBlockStoreMessage self (BlockNotFound p bs) = do + logDebug self $ + "Blocks not found by peer " + <> p.label + <> ": " + <> T.unwords (map blockHashToHex bs) + processNoBlocks self p bs +processBlockStoreMessage self (TxRefReceived p tx) = do + logDebug self $ + "Transaction received from peer " + <> p.label + <> ": " + <> txHashToHex (txHash tx) + processTx self p tx +processBlockStoreMessage self (TxRefAvailable p ts) = do + logDebug self $ + "Transactions available from peer " + <> p.label + <> ": " + <> T.unwords (map txHashToHex ts) + processTxs self p ts +processBlockStoreMessage self (BlockPing r) = do + logDebug self "Internal clock event" + setStoreHeight self + setHeadersHeight self + setPendingTxs self + setPeersConnected self + trySyncing self + processMempool self + pruneOrphans self + pruneMempool self + checkTime self + atomically (r ()) + +-- | Send a clock tick to the block store every 0.1 to 1 second, waiting for each to be handled. +pingMe :: Mailbox BlockStoreMessage -> IO () +pingMe mbox = + loopForever $ do + BlockPing `query` mbox + delay <- randomRIO (100 * 1000, 1000 * 1000) + threadDelay delay + +-- | Tell the block store that a peer connected. +blockStorePeerConnect :: Peer -> BlockStore -> IO () +blockStorePeerConnect peer store = + BlockPeerConnect peer `send` store.mailbox + +-- | Tell the block store that a peer disconnected. +blockStorePeerDisconnect :: + Peer -> BlockStore -> IO () +blockStorePeerDisconnect peer store = + BlockPeerDisconnect peer `send` store.mailbox + +-- | Tell the block store that the node has a new best header. +blockStoreHead :: + BlockNode -> BlockStore -> IO () +blockStoreHead node store = + BlockNewBest node `send` store.mailbox + +-- | Give the block store a block received from a peer. +blockStoreBlock :: + Peer -> Block -> BlockStore -> IO () +blockStoreBlock peer block store = + BlockReceived peer block `send` store.mailbox + +-- | Tell the block store that a peer could not find blocks. +blockStoreNotFound :: + Peer -> [BlockHash] -> BlockStore -> IO () +blockStoreNotFound peer blocks store = + BlockNotFound peer blocks `send` store.mailbox + +-- | Give the block store a transaction received from a peer. +blockStoreTx :: + Peer -> Tx -> BlockStore -> IO () +blockStoreTx peer tx store = + TxRefReceived peer tx `send` store.mailbox + +-- | Tell the block store that a peer announced transactions. +blockStoreTxHash :: + Peer -> [TxHash] -> BlockStore -> IO () +blockStoreTxHash peer txhashes store = + TxRefAvailable peer txhashes `send` store.mailbox + +-- | 'STM' version of 'blockStorePeerConnect'. +blockStorePeerConnectSTM :: + Peer -> BlockStore -> STM () +blockStorePeerConnectSTM peer store = + BlockPeerConnect peer `sendSTM` store.mailbox + +-- | 'STM' version of 'blockStorePeerDisconnect'. +blockStorePeerDisconnectSTM :: + Peer -> BlockStore -> STM () +blockStorePeerDisconnectSTM peer store = + BlockPeerDisconnect peer `sendSTM` store.mailbox + +-- | 'STM' version of 'blockStoreHead'. +blockStoreHeadSTM :: + BlockNode -> BlockStore -> STM () +blockStoreHeadSTM node store = + BlockNewBest node `sendSTM` store.mailbox + +-- | 'STM' version of 'blockStoreBlock'. +blockStoreBlockSTM :: + Peer -> Block -> BlockStore -> STM () +blockStoreBlockSTM peer block store = + BlockReceived peer block `sendSTM` store.mailbox + +-- | 'STM' version of 'blockStoreNotFound'. +blockStoreNotFoundSTM :: + Peer -> [BlockHash] -> BlockStore -> STM () +blockStoreNotFoundSTM peer blocks store = + BlockNotFound peer blocks `sendSTM` store.mailbox + +-- | 'STM' version of 'blockStoreTx'. +blockStoreTxSTM :: + Peer -> Tx -> BlockStore -> STM () +blockStoreTxSTM peer tx store = + TxRefReceived peer tx `sendSTM` store.mailbox + +-- | 'STM' version of 'blockStoreTxHash'. +blockStoreTxHashSTM :: + Peer -> [TxHash] -> BlockStore -> STM () +blockStoreTxHashSTM peer txhashes store = + TxRefAvailable peer txhashes `sendSTM` store.mailbox + +-- | Number of transactions queued or requested by the block store. +blockStorePendingTxs :: + BlockStore -> IO Int +blockStorePendingTxs = + atomically . blockStorePendingTxsSTM + +-- | 'STM' version of 'blockStorePendingTxs'. +blockStorePendingTxsSTM :: + BlockStore -> STM Int +blockStorePendingTxsSTM store = Pending.size <$> readTVar store.pending -- | Describe a block for logs: height, time, hash and, if the block is given, size. blockText :: BlockNode -> Maybe Block -> Text diff --git a/src/Haskoin/Store/BlockStore/Pending.hs b/src/Haskoin/Store/BlockStore/Pending.hs new file mode 100644 --- /dev/null +++ b/src/Haskoin/Store/BlockStore/Pending.hs @@ -0,0 +1,166 @@ +-- | +-- Module : Haskoin.Store.BlockStore.Pending +-- Copyright : (c) Haskoin Developers +-- License : MIT +-- Maintainer : jprupp@protonmail.ch +-- Stability : experimental +-- Portability : POSIX +-- +-- Mempool transactions on their way into the database, as a pure value with +-- transitions. +-- +-- A transaction that a peer announces goes through these states: +-- +-- @ +-- announced ──► requested ──► received ──► ready ──► taken for import +-- │ │ (missing parents arrive) +-- ▼ ▼ +-- forgotten dropped +-- (after 20 s) (after an hour) +-- @ +-- +-- It is requested once, and not again while the request is fresh. Once +-- received, it waits until no parent is missing, and is then taken for +-- import together with other ready transactions, parents first. +-- +-- = Why a pure value +-- +-- The block store kept the queue and the recent requests in two variables, +-- changed by several functions, and forgot each request in a thread of its +-- own that slept for twenty seconds: one thread per transaction requested. +-- Here every change is a function, the clock is an argument, and requests +-- are forgotten by 'prune' on the clock tick of the block store, like the +-- transactions that waited too long. +module Haskoin.Store.BlockStore.Pending + ( -- * State + Pending, + PendingTx (..), + empty, + isPending, + queued, + size, + waiting, + + -- * Transitions + requested, + received, + takeReady, + imported, + refresh, + prune, + + -- * Timeouts + requestTimeout, + orphanTimeout, + ) +where + +import Data.HashMap.Strict (HashMap) +import Data.HashMap.Strict qualified as HashMap +import Data.HashSet (HashSet) +import Data.HashSet qualified as HashSet +import Data.Maybe (mapMaybe) +import Data.Time.Clock (NominalDiffTime, UTCTime, diffUTCTime) +import Haskoin (Tx, TxHash, txHash) +import Haskoin.Store.Common (sortTxs) + +-- | Transaction received from a peer and waiting to be imported. +data PendingTx = PendingTx + { -- | when it was received + time :: !UTCTime, + -- | the transaction + tx :: !Tx, + -- | parent transactions that are missing; empty if it can be imported + deps :: !(HashSet TxHash) + } + deriving stock (Show, Eq, Ord) + +-- | Transactions requested from peers and received from them. +data Pending = Pending + { -- | received, by hash + txs :: !(HashMap TxHash PendingTx), + -- | requested and not received yet, with when + asked :: !(HashMap TxHash UTCTime) + } + deriving stock (Show, Eq) + +-- | How long a request keeps the transaction from being requested again. +requestTimeout :: NominalDiffTime +requestTimeout = 20 + +-- | How long a transaction waits for missing parents. +orphanTimeout :: NominalDiffTime +orphanTimeout = 3600 + +-- | Nothing requested or received. +empty :: Pending +empty = Pending HashMap.empty HashMap.empty + +-- | Whether a transaction is received or requested, so that it is not +-- requested again. +isPending :: TxHash -> Pending -> Bool +isPending h p = HashMap.member h p.txs || HashMap.member h p.asked + +-- | How many transactions are received and not taken for import yet. +queued :: Pending -> Int +queued p = HashMap.size p.txs + +-- | How many transactions are received or requested. +size :: Pending -> Int +size p = HashMap.size (HashMap.union (() <$ p.txs) (() <$ p.asked)) + +-- | Received transactions that have missing parents. +waiting :: Pending -> [PendingTx] +waiting p = filter (not . null . (.deps)) (HashMap.elems p.txs) + +-- | Transactions were requested. +requested :: UTCTime -> [TxHash] -> Pending -> Pending +requested now hs p = p {asked = HashMap.union (HashMap.fromList [(h, now) | h <- hs]) p.asked} + +-- | A transaction was received, with the parents that it spends and the +-- database does not have. It is no longer a request. +received :: UTCTime -> Tx -> HashSet TxHash -> Pending -> Pending +received now tx deps p = + Pending + { txs = HashMap.insert h (PendingTx now tx deps) p.txs, + asked = HashMap.delete h p.asked + } + where + h = txHash tx + +-- | Take up to this many transactions with no missing parents, parents +-- before children. +takeReady :: Int -> Pending -> ([PendingTx], Pending) +takeReady n p = (taken, p {txs = foldr (HashMap.delete . txHash . (.tx)) p.txs taken}) + where + ready = HashMap.filter (null . (.deps)) p.txs + taken = + take n $ + mapMaybe ((`HashMap.lookup` ready) . txHash . snd) (sortTxs (map (.tx) (HashMap.elems ready))) + +-- | A transaction is in the database: transactions waiting for it no longer +-- miss it. +imported :: TxHash -> Pending -> Pending +imported h p = p {txs = HashMap.map (\t -> t {deps = HashSet.delete h t.deps}) p.txs} + +-- | After a block, give each waiting transaction what the database now +-- says about it: 'Nothing' if it is in the database already, so it is +-- dropped, or the parents that it still misses. +refresh :: HashMap TxHash (Maybe (HashSet TxHash)) -> Pending -> Pending +refresh updates p = p {txs = HashMap.mapMaybeWithKey update p.txs} + where + update h t = case HashMap.lookup h updates of + Nothing -> Just t + Just Nothing -> Nothing + Just (Just deps) -> Just t {deps = deps} + +-- | Forget requests older than 'requestTimeout', and drop transactions +-- received longer than 'orphanTimeout' ago. +prune :: UTCTime -> Pending -> Pending +prune now p = + Pending + { txs = HashMap.filter (\t -> age t.time <= orphanTimeout) p.txs, + asked = HashMap.filter (\t -> age t <= requestTimeout) p.asked + } + where + age t = now `diffUTCTime` t diff --git a/src/Haskoin/Store/BlockStore/Sync.hs b/src/Haskoin/Store/BlockStore/Sync.hs new file mode 100644 --- /dev/null +++ b/src/Haskoin/Store/BlockStore/Sync.hs @@ -0,0 +1,178 @@ +-- | +-- Module : Haskoin.Store.BlockStore.Sync +-- Copyright : (c) Haskoin Developers +-- License : MIT +-- Maintainer : jprupp@protonmail.ch +-- Stability : experimental +-- Portability : POSIX +-- +-- The state of the block download, as a pure state machine. +-- +-- The block store downloads blocks from one peer at a time. It is either +-- 'Idle', with no syncing peer, or 'Syncing' from one peer, with the blocks +-- requested from it and not yet imported, in chain order. Every change of +-- that state is one of the transitions of this module, and the block store +-- only carries out what they decide: lock or release a peer, send a request, +-- disconnect a peer. +-- +-- = Why a state machine +-- +-- The block store used to keep this state in a @TVar (Maybe Syncing)@ that a +-- dozen functions changed in place, each with its own check of who the peer +-- was and what had been asked. Bugs in such code, like a peer left locked or +-- a block accepted that nobody asked for, show up as a sync that stops for no +-- visible reason. Pure transitions can be tested on their own, with any +-- sequence of events, and the rules are in one place: +-- +-- * There is at most one syncing peer, and only 'start' sets one, from 'Idle'. +-- * Only blocks requested from the syncing peer are accepted ('accept'), so a +-- block from another peer, or one nobody asked for, is a reason to +-- disconnect the peer that sent it. +-- * A block is requested at most once while it is outstanding ('request'). +-- * The peer times out when it has delivered nothing for a while +-- ('timedOut'); delivering a block or starting resets the clock. +-- +-- The peer is a type parameter so that the tests can use plain numbers. +module Haskoin.Store.BlockStore.Sync + ( -- * State + Sync (..), + Download (..), + syncingPeer, + outstanding, + lastRequested, + + -- * Transitions + start, + release, + Accept (..), + accept, + imported, + request, + forgetRequests, + + -- * Decisions + wantsMore, + needsMoreBlocks, + timedOut, + ) +where + +import Data.List (delete) +import Data.Time.Clock (NominalDiffTime, UTCTime, diffUTCTime) +import Haskoin (BlockHash) + +-- | State of the block download from peers of type @p@. +data Sync p + = -- | no syncing peer + Idle + | -- | downloading from a peer + Syncing !(Download p) + deriving stock (Eq, Show) + +-- | A download from the syncing peer. +data Download p = Download + { -- | the peer, locked for the block store + peer :: !p, + -- | when it last delivered a block, or when syncing started + time :: !UTCTime, + -- | blocks requested and not yet imported, in chain order + blocks :: ![BlockHash] + } + deriving stock (Eq, Show) + +-- | The syncing peer, if any. +syncingPeer :: Sync p -> Maybe p +syncingPeer Idle = Nothing +syncingPeer (Syncing d) = Just d.peer + +-- | Blocks requested from the syncing peer and not yet imported. +outstanding :: Sync p -> [BlockHash] +outstanding Idle = [] +outstanding (Syncing d) = d.blocks + +-- | The last block requested, if any is outstanding: the next request +-- starts after it. +lastRequested :: Sync p -> Maybe BlockHash +lastRequested s = case outstanding s of + [] -> Nothing + bs -> Just (last bs) + +-- | Start syncing from a peer, if there is no syncing peer yet. The caller +-- locks the peer first, and frees it again if this gives 'Nothing'. +start :: UTCTime -> p -> Sync p -> Maybe (Sync p) +start now p Idle = Just (Syncing (Download p now [])) +start _ _ (Syncing _) = Nothing + +-- | Stop syncing from a peer, when it disconnects or the store is in sync. +-- Gives the new state, and whether the peer was the syncing peer, in which +-- case the caller frees it. Another peer leaves the state as it is. +release :: (Eq p) => p -> Sync p -> (Bool, Sync p) +release p (Syncing d) + | d.peer == p = (True, Idle) +release _ s = (False, s) + +-- | What to do with a block that a peer sent. +data Accept + = -- | it was requested from this peer: import it + Requested + | -- | the peer is not the syncing peer + NotSyncingPeer + | -- | the syncing peer sent a block that is not outstanding + NotRequested + deriving stock (Eq, Show) + +-- | Whether to import a block that a peer sent. Anything but 'Requested' +-- means the peer misbehaves, or that the requests were forgotten after a +-- reorganisation and the block is from the old chain. +accept :: (Eq p) => p -> BlockHash -> Sync p -> Accept +accept p h = \case + Syncing d + | d.peer /= p -> NotSyncingPeer + | h `elem` d.blocks -> Requested + | otherwise -> NotRequested + Idle -> NotSyncingPeer + +-- | A requested block was imported: it is no longer outstanding, and the +-- peer is not idle. +imported :: UTCTime -> BlockHash -> Sync p -> Sync p +imported _ _ Idle = Idle +imported now h (Syncing d) = Syncing d {time = now, blocks = delete h d.blocks} + +-- | Blocks were requested from the syncing peer. Blocks already outstanding +-- are not added twice. Nothing changes when idle, as there is nobody to ask. +request :: [BlockHash] -> Sync p -> Sync p +request _ Idle = Idle +request hs (Syncing d) = Syncing d {blocks = foldl' add d.blocks hs} + where + add bs h = if h `elem` bs then bs else bs <> [h] + +-- | Forget the outstanding requests, after blocks were reverted: they +-- continued a chain that is no longer the best. Blocks of them that still +-- arrive are 'NotRequested'. +forgetRequests :: Sync p -> Sync p +forgetRequests Idle = Idle +forgetRequests (Syncing d) = Syncing d {blocks = []} + +-- | The syncing peer, if it is time to ask it for more blocks, given the +-- size of the window. +wantsMore :: Int -> Sync p -> Maybe p +wantsMore _ Idle = Nothing +wantsMore window (Syncing d) + | needsMoreBlocks window (length d.blocks) = Just d.peer + | otherwise = Nothing + +-- | Whether to ask for the next batch, given the window size and how many +-- requested blocks are still waiting to be imported. Asking once fewer than +-- a quarter of the window remain keeps the peer busy, while the queue of +-- downloaded blocks never grows much beyond one window. The threshold is at +-- least one, so that a window smaller than four still refills once empty. +needsMoreBlocks :: Int -> Int -> Bool +needsMoreBlocks window n = n < max 1 (window `div` 4) + +-- | The syncing peer, if it has delivered nothing for longer than the +-- timeout. +timedOut :: NominalDiffTime -> UTCTime -> Sync p -> Maybe p +timedOut _ _ Idle = Nothing +timedOut timeout now (Syncing d) + | now `diffUTCTime` d.time > timeout = Just d.peer + | otherwise = Nothing 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 @@ -1,1761 +1,1534 @@ -{-# LANGUAGE ApplicativeDo #-} -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ImportQualifiedPost #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE OverloadedRecordDot #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE NoFieldSelectors #-} - --- | --- Module : Haskoin.Store.Cache --- Copyright : (c) Haskoin Developers --- License : MIT --- Maintainer : jprupp@protonmail.ch --- Stability : experimental --- Portability : POSIX --- --- Redis cache for extended public keys (xpubs). --- --- Answering a query about an xpub from the database means deriving its --- addresses and reading the index of every one of them, which is slow for --- wallets with many used addresses. When such an xpub is queried, its balances, --- transactions and unspent outputs are copied to Redis, and later queries are --- answered from there. Only xpubs with at least 'minAddrs' used addresses are --- cached, and only while the store is in sync. --- --- A cache writer process ('cacheWriter') keeps cached xpubs up to date as new --- blocks and mempool transactions arrive. When Redis holds more than 'maxKeys' --- keys, the xpubs used least recently are evicted. --- --- = Redis keys --- --- * @b\@: hash of derivation path to balance of each address. --- * @t\@: sorted set of transactions, scored by 'blockRefScore'. --- * @u\@: sorted set of unspent outputs, scored by 'blockRefScore'. --- * @a\@: xpub and derivation path of a cached address. --- * @max@: sorted set of cached xpubs, scored by time of last use. --- * @mempool@: sorted set of mempool transactions. --- * @head@: last block that the cache has processed. --- * @xlock-\@, @lock@, @i\@: locks. --- --- Here @\@ and @\@ stand for their binary serialization. --- = Why a cache, and why Redis --- --- Most xpubs are small and fast to answer from RocksDB. A few, such as the --- wallets of exchanges and payment processors, have thousands of used addresses --- and are queried constantly. Answering them from the database means deriving and --- reading every address each time. Keeping their balances, transactions and --- unspent outputs ready in sorted sets turns those queries into a single range --- read. --- --- Redis fits because sorted sets are exactly the shape of these queries, and --- because several store instances can share one cache. Only large xpubs are --- cached ('minAddrs'), because small ones gain nothing, and xpubs not used for a --- while are evicted, so the cache holds the working set rather than everything --- ever queried. --- --- Locks keep two store instances, or two requests, from building the cache of --- the same xpub at the same time. A request that cannot get a lock in time is --- answered from the database rather than made to wait. -module Haskoin.Store.Cache - ( CacheConfig (..), - CacheMetrics, - CacheT, - CacheError (..), - newCacheMetrics, - withCache, - connectRedis, - blockRefScore, - scoreBlockRef, - CacheWriter, - CacheWriterInbox, - cacheNewBlock, - cacheNewTx, - cacheSyncMempool, - cacheWriter, - cacheDelXPubs, - isInCache, - ) -where - -import Control.DeepSeq (NFData) -import Control.Monad (forM, forM_, unless, void, when) -import Control.Monad.Reader (ReaderT (..), asks) -import Control.Monad.Trans (lift) -import Data.Bits (shift, (.&.), (.|.)) -import Data.ByteString (ByteString) -import Data.Default (def) -import Data.Either (fromRight, isRight, rights) -import Data.Functor ((<&>)) -import Data.HashMap.Strict (HashMap) -import Data.HashMap.Strict qualified as HashMap -import Data.HashSet qualified as HashSet -import Data.IntMap.Strict qualified as I -import Data.List (sort) -import Data.List.NonEmpty qualified as NonEmpty -import Data.Map.Strict qualified as Map -import Data.Maybe - ( catMaybes, - mapMaybe, - ) -import Data.Serialize (Serialize, decode, encode) -import Data.String.Conversions (cs) -import Data.Text (Text) -import Data.Time.Clock.POSIX (getPOSIXTime) -import Data.Word (Word32, Word64) -import Database.Redis - ( Connection, - Redis, - RedisCtx, - Reply, - checkedConnect, - defaultConnectInfo, - hgetall, - parseConnectInfo, - zadd, - zrangeWithscores, - zrangebyscoreWithscoresLimit, - zrem, - ) -import Database.Redis qualified as Redis -import GHC.Generics (Generic) -import Haskoin - ( Address, - BlockHash, - BlockNode (..), - Ctx, - DerivPathI (..), - KeyIndex, - Network, - OutPoint (..), - Tx (..), - TxHash, - TxIn (..), - TxOut (..), - XPubKey, - blockHashToHex, - derivePubPath, - eitherToMaybe, - headerHash, - pathToList, - scriptToAddressBS, - txHash, - txHashToHex, - xPubAddr, - xPubCompatWitnessAddr, - xPubExport, - xPubWitnessAddr, - ) -import Haskoin.Node - ( Chain, - LogLevel (..), - Logger, - chainGetBest, - chainGetBlock, - chainGetParents, - chainGetSplitBlock, - logAt, - ) -import Haskoin.Store.Common -import Haskoin.Store.Data -import Haskoin.Store.Database.Reader (DatabaseReader, withDB) -import NQE - ( Inbox, - Listen, - Mailbox, - mailboxEmptySTM, - query, - receive, - receiveSTM, - requeueSTM, - send, - ) -import System.Metrics.StatsD -import UnliftIO - ( Exception, - MonadIO, - MonadUnliftIO, - atomically, - bracket, - liftIO, - throwIO, - withAsync, - ) -import UnliftIO.Concurrent (threadDelay) - --- | Run a Redis command. Throws 'RedisError' if Redis returns an error. -runRedis :: (MonadIO m) => Redis (Either Reply a) -> CacheX m a -runRedis action = do - conn <- asks (.redis) - logger <- asks (.logger) - withRedis logger conn action - --- | Run a Redis command on a connection. Logs and throws 'RedisError' if Redis returns an error. -withRedis :: - (MonadIO m) => Logger -> Connection -> Redis (Either Reply a) -> m a -withRedis logger conn action = - liftIO (Redis.runRedis conn action) >>= \case - Right x -> return x - Left e -> do - logAt LevelError logger $ "Got error from Redis: " <> cs (show e) - throwIO (RedisError e) - --- | Cache configuration. -data CacheConfig = CacheConfig - { -- | connection to Redis - redis :: !Connection, - -- | cache xpubs with at least this many used addresses - minAddrs :: !Int, - -- | evict xpubs when Redis holds more keys than this - maxKeys :: !Integer, - -- | header chain, used to know whether the store is in sync - chain :: !Chain, - -- | StatsD metrics, if enabled - metrics :: !(Maybe CacheMetrics), - -- | log messages here - logger :: !Logger - } - --- | StatsD metrics of the cache. -data CacheMetrics = CacheMetrics - { -- | xpub balance queries answered from the cache (@cache.hits@) - hits :: !StatCounter, - -- | xpub balance queries not in the cache (@cache.misses@) - misses :: !StatCounter, - -- | locks acquired (@cache.lock_acquired@) - lockAcquired :: !StatCounter, - -- | locks released (@cache.lock_released@) - lockReleased :: !StatCounter, - -- | locks that could not be acquired (@cache.lock_failed@) - lockFailed :: !StatCounter, - -- | xpub balances served (@cache.xpub_balances@) - xBalances :: !StatCounter, - -- | xpub unspent outputs served (@cache.xpub_unspents@) - xUnspents :: !StatCounter, - -- | xpub transactions served (@cache.xpub_txs@) - xTxs :: !StatCounter, - -- | xpub transaction counts served (@cache.xpub_tx_count@) - xTxCount :: !StatCounter, - -- | milliseconds to cache an xpub (@cache.index@) - indexTime :: !StatTiming, - -- | height of the last block processed by the cache (@cache.height@) - height :: !StatGauge - } - --- | Register the cache metrics with a StatsD client. -newCacheMetrics :: - (MonadIO m) => - Logger -> - Stats -> - Connection -> - DatabaseReader -> - m CacheMetrics -newCacheMetrics logger s r db = do - h <- redisBest - hits <- c "cache.hits" - misses <- c "cache.misses" - lockAcquired <- c "cache.lock_acquired" - lockReleased <- c "cache.lock_released" - lockFailed <- c "cache.lock_failed" - indexTime <- d "cache.index" - xBalances <- c "cache.xpub_balances" - xUnspents <- c "cache.xpub_unspents" - xTxs <- c "cache.xpub_txs" - xTxCount <- c "cache.xpub_tx_count" - height <- newStatGauge s "cache.height" h - return CacheMetrics {..} - where - redisBest = - maybe dbBest dbBlock =<< withRedis logger r redisGetHead - dbBlock h = - maybe 0 (fromIntegral . (.height)) <$> withDB db (getBlock h) - dbBest = - maybe (return 0) dbBlock =<< withDB db getBestBlock - c x = newStatCounter s x 10 - d x = newStatTiming s x 10 - --- | Record how long an action takes in a timing metric. -withTiming :: - (MonadUnliftIO m) => - (CacheMetrics -> StatTiming) -> - CacheX m a -> - CacheX m a -withTiming df go = - asks (.metrics) >>= \case - Nothing -> go - Just m -> - bracket - time - (end m) - (const go) - where - time = round . (* 1000) <$> liftIO getPOSIXTime - end m t1 = time >>= addTiming (df m) . subtract t1 - --- | Run an action with the metrics, if they are enabled. -withMetrics :: - (MonadIO m) => (CacheMetrics -> CacheX m a) -> CacheX m () -withMetrics go = asks (.metrics) >>= mapM_ go - --- | Monad transformer that may use the cache. With 'Nothing', every query goes --- to the underlying store. Run it with 'withCache'. -type CacheT = ReaderT (Maybe CacheConfig) - --- | Monad transformer that uses the cache. -type CacheX = ReaderT CacheConfig - --- | Log a message with the logger of the cache. -logDebug, logInfo, logWarn, logError :: (MonadIO m) => Text -> CacheX m () -logDebug = cacheLog LevelDebug -logInfo = cacheLog LevelInfo -logWarn = cacheLog LevelWarn -logError = cacheLog LevelError - --- | Log a message at a level with the logger of the cache. -cacheLog :: (MonadIO m) => LogLevel -> Text -> CacheX m () -cacheLog l msg = asks (.logger) >>= \lg -> logAt l lg msg - --- | Errors of the cache. -data CacheError - = -- | Redis returned an error - RedisError Reply - | -- | a Redis transaction failed - RedisTxError !String - | -- | the cache is inconsistent with the database - LogicError !String - deriving (Show, Eq, Generic, NFData, Exception) - --- | Connect to Redis at a URL such as @redis:\/\/localhost:6379@, or with the --- default settings if the URL is empty. Calls 'error' if the URL is invalid. -connectRedis :: (MonadIO m) => String -> m Connection -connectRedis redisurl = do - conninfo <- - if null redisurl - then return defaultConnectInfo - else case parseConnectInfo redisurl of - Left e -> error e - Right r -> return r - liftIO (checkedConnect conninfo) - -instance (StoreReadBase m) => StoreReadBase (CacheX m) where - getCtx = lift getCtx - getNetwork = lift getNetwork - getBestBlock = lift getBestBlock - getBlocksAtHeight = lift . getBlocksAtHeight - getBlock = lift . getBlock - getTxData = lift . getTxData - getManyTxData = lift . getManyTxData - getSpender = lift . getSpender - getBalance = lift . getBalance - getUnspent = lift . getUnspent - getMempool = lift getMempool - getMempoolPage = lift . getMempoolPage - -instance (StoreReadBase m) => StoreReadBase (CacheT m) where - getCtx = lift getCtx - getNetwork = lift getNetwork - getBestBlock = lift getBestBlock - getBlocksAtHeight = lift . getBlocksAtHeight - getBlock = lift . getBlock - getTxData = lift . getTxData - getManyTxData = lift . getManyTxData - getSpender = lift . getSpender - getBalance = lift . getBalance - getUnspent = lift . getUnspent - getMempool = lift getMempool - getMempoolPage = lift . getMempoolPage - -instance - (MonadUnliftIO m, StoreReadExtra m) => - StoreReadExtra (CacheX m) - where - getBalances = lift . getBalances - getAddressesTxs addrs = lift . getAddressesTxs addrs - getAddressTxs addr = lift . getAddressTxs addr - getAddressUnspents addr = lift . getAddressUnspents addr - getAddressesUnspents addrs = lift . getAddressesUnspents addrs - getMaxGap = lift getMaxGap - getInitialGap = lift getInitialGap - getNumTxData = lift . getNumTxData - xPubTxs = getXPubTxs - xPubTxCount = getXPubTxCount - xPubBals = getXPubBalances - xPubUnspents = getXPubUnspents - -instance - (MonadUnliftIO m, StoreReadExtra m) => - StoreReadExtra (CacheT m) - where - getBalances = lift . getBalances - getAddressesTxs addrs = lift . getAddressesTxs addrs - getAddressTxs addr = lift . getAddressTxs addr - getAddressUnspents addr = lift . getAddressUnspents addr - getAddressesUnspents addrs = lift . getAddressesUnspents addrs - getMaxGap = lift getMaxGap - getInitialGap = lift getInitialGap - getNumTxData = lift . getNumTxData - xPubBals xpub = - ReaderT $ \case - Nothing -> xPubBals xpub - Just cfg -> runReaderT (xPubBals xpub) cfg - xPubUnspents xpub xbals limits = - ReaderT $ \case - Nothing -> xPubUnspents xpub xbals limits - Just cfg -> runReaderT (xPubUnspents xpub xbals limits) cfg - xPubTxs xpub xbals limits = - ReaderT $ \case - Nothing -> xPubTxs xpub xbals limits - Just cfg -> runReaderT (xPubTxs xpub xbals limits) cfg - xPubTxCount xpub xbals = - ReaderT $ \case - Nothing -> xPubTxCount xpub xbals - Just cfg -> runReaderT (xPubTxCount xpub xbals) cfg - --- | Run queries with the cache, or without it if 'Nothing'. -withCache :: Maybe CacheConfig -> CacheT m a -> m a -withCache s f = runReaderT f s - --- | Prefix of the keys of xpub balances. -balancesPfx :: ByteString -balancesPfx = "b" - --- | Prefix of the keys of xpub transactions. -txSetPfx :: ByteString -txSetPfx = "t" - --- | Prefix of the keys of xpub unspent outputs. -utxoPfx :: ByteString -utxoPfx = "u" - --- | Prefix of the keys that mark an xpub as being cached. -idxPfx :: ByteString -idxPfx = "i" - --- | Key of the lock held while caching an xpub. -xpubLock :: XPubSpec -> ByteString -xpubLock xpub = "xlock-" <> encode xpub - --- | Run a read of the cache entries of an xpub in the same round trip to --- Redis as the check that the xpub is cached. Redis pipelines the two --- commands, since the reply of the first is not read before the second is --- sent. The read is 'Nothing' if the xpub is not cached; it then found no --- entries, as the keys of an xpub are all deleted together. -whenXPubCached :: - (MonadIO m) => - XPubSpec -> - Redis (Either Reply a) -> - CacheX m (Maybe a) -whenXPubCached xpub action = do - (cached, x) <- runRedis $ do - e <- redisIsXPubCached xpub - r <- action - return $ (,) <$> e <*> r - return $ if cached then Just x else Nothing - --- | The score to start reading a sorted set of an xpub from, when it does --- not need a database lookup. -startScore :: Maybe Start -> Maybe (Maybe Double) -startScore Nothing = Just Nothing -startScore (Just (AtBlock h)) = Just (Just (blockRefScore (BlockRef h maxBound))) -startScore (Just AtTx {}) = Nothing - --- | Transactions of an xpub, from the cache if it is cached, or from the store otherwise. -getXPubTxs :: - (MonadUnliftIO m, StoreReadExtra m) => - XPubSpec -> - [XPubBal] -> - Limits -> - CacheX m [TxRef] -getXPubTxs xpub xbals limits = - case startScore limits.start of - Just score -> - whenXPubCached xpub (get_txs score) >>= \case - Just xs -> do - touchKeys [xpub] - hit (map (\(t, s) -> TxRef {txid = t, block = scoreBlockRef s}) xs) - Nothing -> lift $ xPubTxs xpub xbals limits - Nothing -> do - cached <- isXPubCached xpub - if cached - then hit =<< cacheGetXPubTxs xpub limits - else lift $ xPubTxs xpub xbals limits - where - get_txs score = - getFromSortedSet - (txSetPfx <> encode xpub) - score - limits.offset - limits.limit - hit txs = do - withMetrics $ \s -> - incrementCounter s.xTxs (length txs) - return txs - --- | Number of transactions of an xpub, from the cache if it is cached, or from the store otherwise. -getXPubTxCount :: - (MonadUnliftIO m, StoreReadExtra m) => - XPubSpec -> - [XPubBal] -> - CacheX m Word32 -getXPubTxCount xpub xbals = - whenXPubCached xpub (redisGetXPubTxCount xpub) >>= \case - Just count -> do - withMetrics $ \s -> - incrementCounter s.xTxCount 1 - touchKeys [xpub] - return (fromInteger count) - Nothing -> lift $ xPubTxCount xpub xbals - --- | Unspent outputs of an xpub, from the cache if it is cached, or from the store otherwise. -getXPubUnspents :: - (MonadUnliftIO m, StoreReadExtra m) => - XPubSpec -> - [XPubBal] -> - Limits -> - CacheX m [XPubUnspent] -getXPubUnspents xpub xbals limits = - case startScore limits.start of - Just score -> - whenXPubCached xpub (get_ops score) >>= \case - Just xs -> do - touchKeys [xpub] - hit (map fst xs) - Nothing -> lift $ xPubUnspents xpub xbals limits - Nothing -> do - cached <- isXPubCached xpub - if cached - then hit . map snd =<< cacheGetXPubUnspents xpub limits - else lift $ xPubUnspents xpub xbals limits - where - get_ops score = - getFromSortedSet - (utxoPfx <> encode xpub) - score - limits.offset - limits.limit - hit ops = do - uns <- catMaybes <$> lift (mapM getUnspent ops) - net <- lift getNetwork - ctx <- lift getCtx - let f u = - either - (const Nothing) - (\a -> Just (a, u)) - (scriptToAddressBS net ctx u.script) - xm = - let j x = (x.balance.address, x) - k = (> 0) . (.balance.utxo) - in HashMap.fromList $ map j $ filter k xbals - g a = HashMap.lookup a xm - h u x = - XPubUnspent - { unspent = u, - path = x.path - } - us = mapMaybe f uns - i a u = h u <$> g a - withMetrics $ \s -> incrementCounter s.xUnspents (length us) - return $ mapMaybe (uncurry i) us - --- | Balances of an xpub, from the cache if it is cached. Otherwise read them from --- the store and cache the xpub if it has enough used addresses. -getXPubBalances :: - (MonadUnliftIO m, StoreReadExtra m) => - XPubSpec -> - CacheX m [XPubBal] -getXPubBalances xpub = - whenXPubCached xpub (redisGetXPubBalances xpub) >>= \case - Just xbals -> do - touchKeys [xpub] - withMetrics $ \s -> do - incrementCounter s.hits 1 - incrementCounter s.xBalances (length xbals) - return xbals - Nothing -> do - withMetrics $ \s -> incrementCounter s.misses 1 - withRetryLock (xpubLock xpub) (load_and_cache xpub) >>= \case - Just bals -> return bals - Nothing -> do - -- Another thread held the lock for too long: serve from the - -- database without caching rather than wait any longer. - logWarn "Could not acquire xpub lock, serving from database" - lift $ xPubBals xpub - where - load_and_cache x = do - bals <- lift $ xPubBals x - newXPubC x bals - return bals - --- | Whether an xpub is cached. Always 'False' without a cache. -isInCache :: (MonadIO m) => XPubSpec -> CacheT m Bool -isInCache xpub = - ReaderT $ \case - Nothing -> return False - Just cfg -> runReaderT (isXPubCached xpub) cfg - --- | Whether an xpub is cached. -isXPubCached :: (MonadIO m) => XPubSpec -> CacheX m Bool -isXPubCached xpub = runRedis (redisIsXPubCached xpub) - --- | Redis command to check whether an xpub is cached. -redisIsXPubCached :: (RedisCtx m f) => XPubSpec -> m (f Bool) -redisIsXPubCached xpub = Redis.exists (balancesPfx <> encode xpub) - --- | Redis command to count the transactions of an xpub. -redisGetXPubTxCount :: (RedisCtx m f) => XPubSpec -> m (f Integer) -redisGetXPubTxCount xpub = Redis.zcard (txSetPfx <> encode xpub) - --- | Page of the cached transactions of an xpub. -cacheGetXPubTxs :: - (StoreReadBase m, MonadIO m) => - XPubSpec -> - Limits -> - CacheX m [TxRef] -cacheGetXPubTxs xpub limits = - case limits.start of - Nothing -> - go1 Nothing - Just (AtTx th) -> - lift (getTxData th) >>= \case - Just TxData {block = b@BlockRef {}} -> - go1 $ Just (blockRefScore b) - _ -> - go2 th - Just (AtBlock h) -> - go1 (Just (blockRefScore (BlockRef h maxBound))) - where - go1 score = do - xs <- - runRedis $ - getFromSortedSet - (txSetPfx <> encode xpub) - score - limits.offset - limits.limit - touchKeys [xpub] - return $ map (uncurry f) xs - go2 hash = do - xs <- - runRedis $ - getFromSortedSet - (txSetPfx <> encode xpub) - Nothing - 0 - 0 - touchKeys [xpub] - let xs' = - if any ((== hash) . fst) xs - then dropWhile ((/= hash) . fst) xs - else [] - return $ - map (uncurry f) $ - l $ - drop (fromIntegral limits.offset) xs' - l = - if limits.limit > 0 - then take (fromIntegral limits.limit) - else id - f t s = TxRef {txid = t, block = scoreBlockRef s} - --- | Page of the cached unspent outputs of an xpub, with their positions. -cacheGetXPubUnspents :: - (StoreReadBase m, MonadIO m) => - XPubSpec -> - Limits -> - CacheX m [(BlockRef, OutPoint)] -cacheGetXPubUnspents xpub limits = - case limits.start of - Nothing -> - go1 Nothing - Just (AtTx th) -> - lift (getTxData th) >>= \case - Just TxData {block = b@BlockRef {}} -> - go1 (Just (blockRefScore b)) - _ -> - go2 th - Just (AtBlock h) -> - go1 (Just (blockRefScore (BlockRef h maxBound))) - where - go1 score = do - xs <- - runRedis $ - getFromSortedSet - (utxoPfx <> encode xpub) - score - limits.offset - limits.limit - touchKeys [xpub] - return $ map (uncurry f) xs - go2 hash = do - xs <- - runRedis $ - getFromSortedSet - (utxoPfx <> encode xpub) - Nothing - 0 - 0 - touchKeys [xpub] - let xs' = - if any ((== hash) . (.hash) . fst) xs - then dropWhile ((/= hash) . (.hash) . fst) xs - else [] - return $ - map (uncurry f) $ - l $ - drop (fromIntegral limits.offset) xs' - l = - if limits.limit > 0 - then take (fromIntegral limits.limit) - else id - f o s = (scoreBlockRef s, o) - --- | Redis command to read the cached balances of an xpub, sorted by path. -redisGetXPubBalances :: (Functor f, RedisCtx m f) => XPubSpec -> m (f [XPubBal]) -redisGetXPubBalances xpub = - fmap (sort . map (uncurry f)) <$> getAllFromMap (balancesPfx <> encode xpub) - where - f p b = XPubBal {path = p, balance = b} - --- | Score of a position in a Redis sorted set, such that sorting by score --- ascending sorts from newest to oldest. Mempool transactions get negative --- scores from their time, so they come first; confirmed ones get positive --- scores that decrease with height and position. --- --- One number has to order mempool and confirmed transactions in a single sorted --- set, newest first, exactly as the database does. Floating point is what Redis --- offers, so the height and position are packed into the 53 bits a double holds --- exactly. -blockRefScore :: BlockRef -> Double -blockRefScore BlockRef {height = h, position = p} = - fromIntegral (0x001fffffffffffff - (h' .|. p')) - where - h' = (fromIntegral h .&. 0x07ffffff) `shift` 26 :: Word64 - p' = (fromIntegral p .&. 0x03ffffff) :: Word64 -blockRefScore MemRef {timestamp = t} = negate t' - where - t' = fromIntegral (t .&. 0x001fffffffffffff) - --- | Inverse of 'blockRefScore'. -scoreBlockRef :: Double -> BlockRef -scoreBlockRef s - | s < 0 = MemRef {timestamp = n} - | otherwise = BlockRef {height = h, position = p} - where - n = truncate (abs s) :: Word64 - m = 0x001fffffffffffff - n - h = fromIntegral (m `shift` (-26)) - p = fromIntegral (m .&. 0x03ffffff) - --- | Redis command to read members of a sorted set, decoded, with their scores, --- from a minimum score if given, skipping an offset, up to a count (@0@ for --- all). -getFromSortedSet :: - (Applicative f, RedisCtx m f, Serialize a) => - ByteString -> - Maybe Double -> - Word32 -> - Word32 -> - m (f [(a, Double)]) -getFromSortedSet key Nothing off 0 = do - xs <- zrangeWithscores key (fromIntegral off) (-1) - return $ do - ys <- map (\(x, s) -> (,s) <$> decode x) <$> xs - return (rights ys) -getFromSortedSet key Nothing off count = do - xs <- - zrangeWithscores - key - (fromIntegral off) - (fromIntegral off + fromIntegral count - 1) - return $ do - ys <- map (\(x, s) -> (,s) <$> decode x) <$> xs - return (rights ys) -getFromSortedSet key (Just score) off 0 = do - xs <- - zrangebyscoreWithscoresLimit - key - score - (1 / 0) - (fromIntegral off) - (-1) - return $ do - ys <- map (\(x, s) -> (,s) <$> decode x) <$> xs - return (rights ys) -getFromSortedSet key (Just score) off count = do - xs <- - zrangebyscoreWithscoresLimit - key - score - (1 / 0) - (fromIntegral off) - (fromIntegral count) - return $ do - ys <- map (\(x, s) -> (,s) <$> decode x) <$> xs - return (rights ys) - --- | Redis command to read all fields of a hash, decoded. -getAllFromMap :: - (Functor f, RedisCtx m f, Serialize k, Serialize v) => - ByteString -> - m (f [(k, v)]) -getAllFromMap n = do - fxs <- hgetall n - return $ do - xs <- fxs - return - [ (k, v) - | (k', v') <- xs, - let k = fromRight undefined $ decode k', - let v = fromRight undefined $ decode v' - ] - --- | Messages handled by the cache writer. -data CacheWriterMessage - = -- | a new block was imported - CacheNewBlock - | -- | a mempool transaction was added or removed - CacheNewTx !TxHash - | -- | internal: a batch of coalesced 'CacheNewTx' events - CacheNewTxs ![TxHash] - | -- | sync the mempool with the database, then reply - CacheSyncMempool !(Listen ()) - --- | Inbox of the cache writer process. -type CacheWriterInbox = Inbox CacheWriterMessage - --- | Mailbox to send messages to the cache writer. -type CacheWriter = Mailbox CacheWriterMessage - --- | Xpub that a cached address belongs to. -data AddressXPub = AddressXPub - { -- | the xpub - spec :: !XPubSpec, - -- | derivation path of the address below the xpub - path :: ![KeyIndex] - } - deriving (Show, Eq, Generic, NFData, Serialize) - --- | Key of the sorted set of mempool transactions. -mempoolSetKey :: ByteString -mempoolSetKey = "mempool" - --- | Prefix of the keys of cached addresses. -addrPfx :: ByteString -addrPfx = "a" - --- | Key of the last block processed by the cache. -bestBlockKey :: ByteString -bestBlockKey = "head" - --- | Key of the sorted set of cached xpubs by time of last use. -maxKey :: ByteString -maxKey = "max" - --- | Address of an extended public key for a type of address. -xPubAddrFunction :: Ctx -> DeriveType -> XPubKey -> Address -xPubAddrFunction ctx DeriveNormal = xPubAddr ctx -xPubAddrFunction ctx DeriveP2SH = xPubCompatWitnessAddr ctx -xPubAddrFunction ctx DeriveP2WPKH = xPubWitnessAddr ctx - --- | Run the cache writer process: bring the cache up to date with the database, --- then handle messages forever. Notifications of new mempool transactions that --- pile up are handled together, up to 1000 at a time. -cacheWriter :: - (MonadUnliftIO m, StoreReadExtra m) => - CacheConfig -> - CacheWriterInbox -> - m () -cacheWriter cfg inbox = - runReaderT go cfg - where - go = do - newBlockC - syncMempoolC - loopForever $ do - logDebug "Awaiting event..." - x <- receive inbox - case x of - CacheNewTx txid -> do - -- Coalesce: every queued CacheNewTx is synced in one pass instead - -- of one Redis round-trip sequence per transaction, so the inbox - -- cannot grow without bound when Redis is slower than the mempool. - more <- liftIO (atomically (drainNewTxs [])) - cacheWriterReact (CacheNewTxs (txid : more)) - _ -> cacheWriterReact x - drainNewTxs acc - | length acc >= 1000 = return (reverse acc) - | otherwise = do - empty <- mailboxEmptySTM inbox - if empty - then return (reverse acc) - else - receiveSTM inbox >>= \case - CacheNewTx t -> drainNewTxs (t : acc) - other -> do - requeueSTM other inbox - return (reverse acc) - --- | Try to take a lock that expires after five minutes. Returns 'True' if taken. -lockIt :: (MonadIO m) => ByteString -> CacheX m Bool -lockIt l = do - go >>= \case - Right Redis.Ok -> do - logDebug "Acquired lock" - withMetrics $ \s -> incrementCounter s.lockAcquired 1 - return True - Right Redis.Pong -> do - logError "Unexpected pong when acquiring lock" - withMetrics $ \s -> incrementCounter s.lockFailed 1 - return False - Right (Redis.Status s) -> do - logError $ - "Unexpected status acquiring lock: " <> cs s - withMetrics $ \m -> incrementCounter m.lockFailed 1 - return False - Left (Redis.Bulk Nothing) -> do - logDebug "Lock already taken" - withMetrics $ \s -> incrementCounter s.lockFailed 1 - return False - Left e -> do - logError "Error when trying to acquire lock" - withMetrics $ \s -> incrementCounter s.lockFailed 1 - throwIO (RedisError e) - where - go = do - conn <- asks (.redis) - liftIO . Redis.runRedis conn $ do - let opts = - Redis.SetOpts - { Redis.setSeconds = Just 300, - Redis.setMilliseconds = Nothing, - Redis.setUnixSeconds = Nothing, - Redis.setUnixMilliseconds = Nothing, - Redis.setCondition = Just Redis.Nx, - Redis.setKeepTTL = False - } - Redis.setOpts l "locked" opts - --- | Extend a lock for another five minutes. -refreshLock :: (MonadIO m) => ByteString -> CacheX m () -refreshLock l = void . runRedis $ do - let opts = - Redis.SetOpts - { Redis.setSeconds = Just 300, - Redis.setMilliseconds = Nothing, - Redis.setUnixSeconds = Nothing, - Redis.setUnixMilliseconds = Nothing, - Redis.setCondition = Just Redis.Xx, - Redis.setKeepTTL = False - } - Redis.setOpts l "locked" opts - --- | Release a lock. -unlockIt :: (MonadIO m) => ByteString -> CacheX m () -unlockIt l = void . runRedis . Redis.del $ NonEmpty.singleton l - --- | Run an action holding a lock, refreshing it every two and a half minutes. Returns 'Nothing' if the lock is taken. -withLock :: - (MonadUnliftIO m) => - ByteString -> - CacheX m a -> - CacheX m (Maybe a) -withLock l f = - bracket (lockIt l) (`when` unlockIt l) $ \case - True -> Just <$> go - False -> return Nothing - where - go = withAsync refresh $ const f - refresh = loopForever $ do - threadDelay (150 * 1000 * 1000) - refreshLock l - --- | Run the action holding the lock, retrying with exponential backoff --- while another thread holds it. The delay between attempts grows from --- 0.2 s to at most 5 s, and after about 30 s of waiting it gives up and --- returns 'Nothing' instead of keeping the calling thread blocked forever. -withRetryLock :: - (MonadUnliftIO m) => - ByteString -> - CacheX m a -> - CacheX m (Maybe a) -withRetryLock l f = - go 0 (200 * 1000) - where - max_delay = 5 * 1000 * 1000 - max_wait = 30 * 1000 * 1000 - go waited n = - withLock l f >>= \case - Just x -> return (Just x) - Nothing - | waited >= max_wait -> return Nothing - | otherwise -> do - threadDelay n - go (waited + n) (min max_delay (n * 2)) - --- | Evict the least recently used xpubs while Redis holds more than the maximum number of keys. -pruneDB :: - (MonadUnliftIO m, StoreReadBase m) => CacheX m () -pruneDB = void . withLock "lock" $ do - x <- asks (.maxKeys) - s <- runRedis Redis.dbsize - logDebug "Pruning old xpubs" - when (s > x) $ - void . delXPubKeys . map fst - =<< runRedis (getFromSortedSet maxKey Nothing 0 (fromIntegral (s - x))) - --- | Record that xpubs were just used. -touchKeys :: (MonadIO m) => [XPubSpec] -> CacheX m () -touchKeys xpubs = do - now <- round <$> liftIO getPOSIXTime :: (MonadIO m) => m Int - runRedis $ redisTouchKeys now xpubs - --- | Redis command to record that xpubs were used at a time. -redisTouchKeys :: (Monad f, RedisCtx m f, Real a) => a -> [XPubSpec] -> m (f ()) -redisTouchKeys _ [] = return $ return () -redisTouchKeys now xpubs = - void <$> Redis.zadd maxKey (map ((realToFrac now,) . encode) xpubs) - --- | Handle a message sent to the cache writer. -cacheWriterReact :: - (MonadUnliftIO m, StoreReadExtra m) => - CacheWriterMessage -> - CacheX m () -cacheWriterReact CacheNewBlock = do - logDebug "Received new block event" - pruneDB - newBlockC - syncMempoolC -cacheWriterReact (CacheNewTx txid) = - cacheWriterReact (CacheNewTxs [txid]) -cacheWriterReact (CacheNewTxs txids) = do - logDebug $ - "Received " <> cs (show (length txids)) <> " new transaction event(s)" - pruneDB - syncNewTxC txids -cacheWriterReact (CacheSyncMempool l) = do - logDebug "Received sync mempool event" - pruneDB - newBlockC - syncMempoolC - atomically $ l () - --- | Number of used addresses in a list of xpub balances. -lenNotNull :: [XPubBal] -> Int -lenNotNull = length . filter (not . nullBalance . (.balance)) - --- | Cache an xpub, if it has enough used addresses, the store is in sync, and no --- other thread is caching it already. -newXPubC :: - (MonadUnliftIO m, StoreReadExtra m) => - XPubSpec -> - [XPubBal] -> - CacheX m () -newXPubC xpub xbals = - should_index >>= \i -> when i $ - bracket set_index unset_index $ \j -> when j $ - withTiming (.indexTime) $ do - xpubtxt <- xpubText xpub - logDebug $ - "Caching " - <> xpubtxt - <> ": " - <> cs (show (length xbals)) - <> " addresses / " - <> cs (show (lenNotNull xbals)) - <> " used" - utxo <- lift $ xPubUnspents xpub xbals def - logDebug $ - "Caching " - <> xpubtxt - <> ": " - <> cs (show (length utxo)) - <> " utxos" - xtxs <- lift $ xPubTxs xpub xbals def - logDebug $ - "Caching " - <> xpubtxt - <> ": " - <> cs (show (length xtxs)) - <> " txs" - now <- round <$> liftIO getPOSIXTime :: (MonadIO m) => m Int - runRedis $ do - b <- redisTouchKeys now [xpub] - c <- redisAddXPubBalances xpub xbals - d <- redisAddXPubUnspents xpub (map op utxo) - e <- redisAddXPubTxs xpub xtxs - return $ b >> c >> d >> e >> return () - logDebug $ "Cached " <> xpubtxt - where - op XPubUnspent {unspent = u} = (u.outpoint, u.block) - should_index = - asks (.minAddrs) >>= \x -> - if x <= lenNotNull xbals - then inSync - else return False - key = idxPfx <> encode xpub - opts = - Redis.SetOpts - { Redis.setSeconds = Just 600, - Redis.setMilliseconds = Nothing, - Redis.setUnixSeconds = Nothing, - Redis.setUnixMilliseconds = Nothing, - Redis.setCondition = Just Redis.Nx, - Redis.setKeepTTL = False - } - red = Redis.setOpts key "1" opts - unset_index y = - when y . void . runRedis . Redis.del $ NonEmpty.singleton key - set_index = do - conn <- asks (.redis) - liftIO (Redis.runRedis conn red) <&> isRight - --- | Whether the best block of the store is the best header of the node. -inSync :: - (MonadUnliftIO m, StoreReadExtra m) => - CacheX m Bool -inSync = - lift getBestBlock >>= \case - Nothing -> return False - Just bb -> do - ch <- asks (.chain) - cb <- liftIO $ chainGetBest ch - return $ cb.height > 0 && headerHash cb.header == bb - --- | Bring the cache up to date with the best block of the store, processing every --- block since the last one it processed, across reorganisations. -newBlockC :: - (MonadUnliftIO m, StoreReadExtra m) => - CacheX m () -newBlockC = - inSync >>= \s -> when s . void . withLock "lock" $ do - get_best_block_node >>= \case - Nothing -> logError "No best block available" - Just best_block_node -> - cacheGetHead >>= \case - Nothing -> do - logInfo "Initializing best cache block" - importBlockC $ headerHash best_block_node.header - Just cache_head_hash -> - get_block_node cache_head_hash >>= \case - Nothing -> do - logError $ - "Could not get best cache block: " - <> blockHashToHex cache_head_hash - Just cache_head_node -> do - blocks <- get_blocks cache_head_node best_block_node - mapM_ importBlockC blocks - where - get_best_block_node = - lift getBestBlock >>= \case - Nothing -> return Nothing - Just best_block_hash -> get_block_node best_block_hash - get_block_node block_hash = do - ch <- asks (.chain) - liftIO $ chainGetBlock ch block_hash - get_blocks left_node right_node = do - ch <- asks (.chain) - split_node <- liftIO $ chainGetSplitBlock ch left_node right_node - let split_node_hash = headerHash split_node.header - right_node_hash = headerHash right_node.header - if split_node_hash == right_node_hash - then return [] - else do - let fork_height = split_node.height + 1 - left_parents <- liftIO $ chainGetParents ch fork_height left_node - right_parents <- liftIO $ chainGetParents ch fork_height right_node - let blocks = reverse left_parents <> right_parents <> pure right_node - return $ map (headerHash . (.header)) blocks - --- | Update cached xpubs with the transactions of a block. -importBlockC :: - (MonadUnliftIO m, StoreReadExtra m) => - BlockHash -> - CacheX m () -importBlockC bh = - lift (getBlock bh) >>= \case - Just bd -> do - let ths = bd.txs - tds <- sortTxData . catMaybes <$> mapM (lift . getTxData) ths - logDebug $ - "Importing " - <> cs (show (length tds)) - <> " transactions from block " - <> blockHashToHex bh - importMultiTxC tds - logDebug $ - "Done importing " - <> cs (show (length tds)) - <> " transactions from block " - <> blockHashToHex bh - cacheSetHead bd - Nothing -> do - logError $ - "Could not get block: " - <> blockHashToHex bh - throwIO . LogicError . cs $ - "Could not get block: " - <> blockHashToHex bh - --- | Update cached xpubs with transactions: their transaction sets, unspent --- outputs, balances and the mempool. Addresses past the gap are derived and --- added when new addresses get used. -importMultiTxC :: - (MonadUnliftIO m, StoreReadExtra m) => - [TxData] -> - CacheX m () -importMultiTxC txs = do - net <- lift getNetwork - ctx <- lift getCtx - logDebug $ "Processing " <> cs (show (length txs)) <> " txs" - logDebug $ - "Getting address information for " - <> cs (show (length (alladdrs net ctx))) - <> " addresses" - addrmap <- getaddrmap net ctx - let addrs = HashMap.keys addrmap - logDebug $ - "Getting balances for " - <> cs (show (HashMap.size addrmap)) - <> " addresses" - balmap <- getbalances addrs - logDebug $ - "Getting unspent data for " - <> cs (show (length (allops net ctx))) - <> " outputs" - unspentmap <- getunspents net ctx - gap <- lift getMaxGap - now <- round <$> liftIO getPOSIXTime :: (MonadIO m) => m Int - let xpubs = allxpubsls addrmap - forM_ (zip [(1 :: Int) ..] xpubs) $ \(i, xpub) -> do - xpubtxt <- xpubText xpub - logDebug $ - "Affected xpub " - <> cs (show i) - <> "/" - <> cs (show (length xpubs)) - <> ": " - <> xpubtxt - addrs' <- do - logDebug $ - "Getting xpub balances for " - <> cs (show (length xpubs)) - <> " xpubs" - xmap <- getxbals xpubs - let addrmap' = faddrmap (HashMap.keysSet xmap) addrmap - logDebug "Starting Redis import pipeline" - runRedis $ do - x <- redisImportMultiTx net ctx addrmap' unspentmap txs - y <- redisUpdateBalances addrmap' balmap - z <- redisTouchKeys now (HashMap.keys xmap) - return $ x >> y >> z >> return () - logDebug "Completed Redis pipeline" - return $ getNewAddrs ctx gap xmap (HashMap.elems addrmap') - cacheAddAddresses addrs' - where - alladdrsls net ctx = HashSet.toList (alladdrs net ctx) - faddrmap xmap = HashMap.filter (\a -> a.spec `elem` xmap) - getaddrmap net ctx = - HashMap.fromList - . catMaybes - . zipWith (\a -> fmap (a,)) (alladdrsls net ctx) - <$> cacheGetAddrsInfo (alladdrsls net ctx) - getunspents net ctx = - HashMap.fromList - . catMaybes - . zipWith (\p -> fmap (p,)) (allops net ctx) - <$> lift (mapM getUnspent (allops net ctx)) - getbalances addrs = - HashMap.fromList . zip addrs <$> mapM (lift . getDefaultBalance) addrs - getxbals xpubs = do - bals <- runRedis . fmap sequence . forM xpubs $ \xpub -> do - bs <- redisGetXPubBalances xpub - return $ (,) xpub <$> bs - return $ HashMap.filter (not . null) (HashMap.fromList bals) - allops net ctx = - map snd $ - concatMap (txInputs net ctx) txs - <> concatMap (txOutputs net ctx) txs - alladdrs net ctx = - HashSet.fromList $ - map fst $ - concatMap (txInputs net ctx) txs - <> concatMap (txOutputs net ctx) txs - allxpubsls = HashSet.toList . allxpubs - allxpubs = - HashSet.fromList . map (.spec) . HashMap.elems - --- | Redis commands to add or remove transactions and unspent outputs of cached xpubs. -redisImportMultiTx :: - (Monad f, RedisCtx m f) => - Network -> - Ctx -> - HashMap Address AddressXPub -> - HashMap OutPoint Unspent -> - [TxData] -> - m (f ()) -redisImportMultiTx net ctx addrmap unspentmap tds = do - xs <- mapM importtxentries tds - return $ sequence_ xs - where - uns p i = - case HashMap.lookup p unspentmap of - Just u -> - redisAddXPubUnspents i.spec [(p, u.block)] - Nothing -> redisRemXPubUnspents i.spec [p] - addtx tx a p = - case HashMap.lookup a addrmap of - Just i -> do - let tr = - TxRef - { txid = txHash tx.tx, - block = tx.block - } - x <- redisAddXPubTxs i.spec [tr] - y <- uns p i - return $ x >> y >> return () - Nothing -> return (pure ()) - remtx tx a p = - case HashMap.lookup a addrmap of - Just i -> do - x <- redisRemXPubTxs i.spec [txHash tx.tx] - y <- uns p i - return $ x >> y >> return () - Nothing -> return (pure ()) - importtxentries td = - if td.deleted - then do - x <- - mapM - (uncurry (remtx td)) - (txaddrops td) - y <- redisRemFromMempool [txHash td.tx] - return $ sequence_ x >> void y - else do - a <- - sequence - <$> mapM - (uncurry (addtx td)) - (txaddrops td) - b <- - case td.block of - b@MemRef {} -> - let tr = - TxRef - { txid = txHash td.tx, - block = b - } - in redisAddToMempool [tr] - _ -> redisRemFromMempool [txHash td.tx] - return $ a >> b >> return () - txaddrops td = txInputs net ctx td <> txOutputs net ctx td - --- | Redis commands to update the balances of cached addresses. -redisUpdateBalances :: - (Monad f, RedisCtx m f) => - HashMap Address AddressXPub -> - HashMap Address Balance -> - m (f ()) -redisUpdateBalances addrmap balmap = - fmap (fmap mconcat . sequence) . forM (HashMap.keys addrmap) $ \a -> - case (HashMap.lookup a addrmap, HashMap.lookup a balmap) of - (Just ainfo, Just bal) -> - redisAddXPubBalances ainfo.spec [xpubbal ainfo bal] - _ -> return (pure ()) - where - xpubbal ainfo bal = - XPubBal {path = ainfo.path, balance = bal} - --- | Add newly derived addresses to their cached xpubs, with their balances, --- transactions and unspent outputs, and keep deriving while they are used. -cacheAddAddresses :: - (StoreReadExtra m, MonadUnliftIO m) => - [(Address, AddressXPub)] -> - CacheX m () -cacheAddAddresses [] = logDebug "No further addresses to add" -cacheAddAddresses addrs = do - ctx <- lift getCtx - logDebug $ - "Adding " <> cs (show (length addrs)) <> " new generated addresses" - logDebug "Getting balances" - balmap <- HashMap.fromListWith (<>) <$> mapM (uncurry getbal) addrs - logDebug "Getting unspent outputs" - utxomap <- HashMap.fromListWith (<>) <$> mapM (uncurry getutxo) addrs - logDebug "Getting transactions" - txmap <- HashMap.fromListWith (<>) <$> mapM (uncurry gettxmap) addrs - logDebug "Running Redis pipeline" - runRedis $ do - a <- forM (HashMap.toList balmap) (uncurry redisAddXPubBalances) - b <- forM (HashMap.toList utxomap) (uncurry redisAddXPubUnspents) - c <- forM (HashMap.toList txmap) (uncurry redisAddXPubTxs) - return $ sequence_ a >> sequence_ b >> sequence_ c - logDebug "Completed Redis pipeline" - let xpubs = - HashSet.toList - . HashSet.fromList - . map (.spec) - $ Map.elems amap - logDebug "Getting xpub balances" - xmap <- getbals xpubs - gap <- lift getMaxGap - let notnulls = getnotnull balmap - addrs' = getNewAddrs ctx gap xmap notnulls - cacheAddAddresses addrs' - where - getbals xpubs = runRedis $ do - bs <- sequence <$> forM xpubs redisGetXPubBalances - return $ - HashMap.filter (not . null) - . HashMap.fromList - . zip xpubs - <$> bs - amap = Map.fromList addrs - getnotnull = - let f xpub = - map $ \bal -> - AddressXPub - { spec = xpub, - path = bal.path - } - g = filter (not . nullBalance . (.balance)) - in concatMap (uncurry f) . HashMap.toList . HashMap.map g - getbal a i = - let f b = - ( i.spec, - [XPubBal {balance = b, path = i.path}] - ) - in f <$> lift (getDefaultBalance a) - getutxo a i = - let f us = - ( i.spec, - map (\u -> (u.outpoint, u.block)) us - ) - in f <$> lift (getAddressUnspents a def) - gettxmap a i = - let f ts = (i.spec, ts) - in f <$> lift (getAddressTxs a def) - --- | Addresses to derive and add to cached xpubs to keep the gap after the used ones. -getNewAddrs :: - Ctx -> - KeyIndex -> - HashMap XPubSpec [XPubBal] -> - [AddressXPub] -> - [(Address, AddressXPub)] -getNewAddrs ctx gap xpubs = - concatMap $ \a -> - case HashMap.lookup a.spec xpubs of - Nothing -> [] - Just bals -> addrsToAdd ctx gap bals a - --- | Update cached xpubs with new or deleted transactions, if in sync. -syncNewTxC :: - (MonadUnliftIO m, StoreReadExtra m) => - [TxHash] -> - CacheX m () -syncNewTxC ths = - inSync >>= \s -> when s . void . withLock "lock" $ do - txs <- catMaybes <$> mapM (lift . getTxData) ths - unless (null txs) $ do - forM_ txs $ \tx -> - logDebug $ - "Synchronizing transaction: " <> txHashToHex (txHash tx.tx) - importMultiTxC txs - --- | Update cached xpubs with every mempool difference between the cache and the store, if in sync. -syncMempoolC :: - (MonadUnliftIO m, StoreReadExtra m) => - CacheX m () -syncMempoolC = - inSync >>= \s -> when s . void . withLock "lock" $ do - nodepool <- HashSet.fromList . map snd <$> lift getMempool - cachepool <- HashSet.fromList . map snd <$> cacheGetMempool - let diff1 = HashSet.difference nodepool cachepool - let diff2 = HashSet.difference cachepool nodepool - let diffset = diff1 <> diff2 - let tids = HashSet.toList diffset - txs <- catMaybes <$> mapM (lift . getTxData) tids - unless (null txs) $ do - logDebug $ - "Synchronizing " <> cs (show (length txs)) <> " mempool transactions" - importMultiTxC txs - --- | Mempool as seen by the cache, newest first. -cacheGetMempool :: (MonadIO m) => CacheX m [(UnixTime, TxHash)] -cacheGetMempool = runRedis redisGetMempool - --- | Last block processed by the cache. -cacheGetHead :: (MonadIO m) => CacheX m (Maybe BlockHash) -cacheGetHead = runRedis redisGetHead - --- | Set the last block processed by the cache. -cacheSetHead :: (MonadIO m) => BlockData -> CacheX m () -cacheSetHead bd = do - logDebug $ "Cache head set to: " <> blockHashToHex bh - void $ runRedis (redisSetHead bh) - withMetrics $ \s -> setGauge s.height (fromIntegral bd.height) - where - bh = headerHash bd.header - --- | Xpub and path of each address, or 'Nothing' if the address is not cached. -cacheGetAddrsInfo :: - (MonadIO m) => [Address] -> CacheX m [Maybe AddressXPub] -cacheGetAddrsInfo as = runRedis (redisGetAddrsInfo as) - --- | Redis command to add transactions to the mempool set. -redisAddToMempool :: (Applicative f, RedisCtx m f) => [TxRef] -> m (f Integer) -redisAddToMempool [] = return (pure 0) -redisAddToMempool btxs = - zadd mempoolSetKey $ - map - (\btx -> (blockRefScore btx.block, encode btx.txid)) - btxs - --- | Redis command to remove transactions from the mempool set. -redisRemFromMempool :: - (Applicative f, RedisCtx m f) => [TxHash] -> m (f Integer) -redisRemFromMempool xs = - case NonEmpty.nonEmpty xs of - Nothing -> return (pure 0) - Just xs' -> zrem mempoolSetKey $ NonEmpty.map encode xs' - --- | Redis command to record the xpub and path of an address. -redisSetAddrInfo :: - (Functor f, RedisCtx m f) => Address -> AddressXPub -> m (f ()) -redisSetAddrInfo a i = void <$> Redis.set (addrPfx <> encode a) (encode i) - --- | Remove xpubs from the cache. Returns the number of keys deleted. -cacheDelXPubs :: - (MonadIO m, StoreReadBase m) => - [XPubSpec] -> - CacheT m Integer -cacheDelXPubs xpubs = ReaderT $ \case - Just cache -> runReaderT (delXPubKeys xpubs) cache - Nothing -> return 0 - --- | Remove xpubs from the cache. Returns the number of keys deleted. -delXPubKeys :: - (MonadIO m, StoreReadBase m) => - [XPubSpec] -> - CacheX m Integer -delXPubKeys [] = return 0 -delXPubKeys xpubs = do - forM_ xpubs $ \x -> do - xtxt <- xpubText x - logDebug $ "Deleting xpub: " <> xtxt - xbals <- - runRedis . fmap sequence . forM xpubs $ \xpub -> do - bs <- redisGetXPubBalances xpub - return $ (xpub,) <$> bs - runRedis $ fmap sum . sequence <$> forM xbals (uncurry redisDelXPubKeys) - --- | Redis commands to remove an xpub and its addresses from the cache. -redisDelXPubKeys :: - (Monad f, RedisCtx m f) => XPubSpec -> [XPubBal] -> m (f Integer) -redisDelXPubKeys xpub bals = go $ map (.balance.address) bals - where - go addrs = do - addrcount <- - case NonEmpty.nonEmpty addrs of - Nothing -> return (pure 0) - Just addrs' -> Redis.del $ NonEmpty.map ((addrPfx <>) . encode) addrs' - txsetcount <- Redis.del $ NonEmpty.singleton (txSetPfx <> encode xpub) - utxocount <- Redis.del $ NonEmpty.singleton (utxoPfx <> encode xpub) - balcount <- Redis.del $ NonEmpty.singleton (balancesPfx <> encode xpub) - x <- Redis.zrem maxKey $ NonEmpty.singleton (encode xpub) - return $ do - _ <- x - addrs' <- addrcount - txset' <- txsetcount - utxo' <- utxocount - bal' <- balcount - return $ addrs' + txset' + utxo' + bal' - --- | Redis command to add transactions to an xpub. -redisAddXPubTxs :: - (Applicative f, RedisCtx m f) => XPubSpec -> [TxRef] -> m (f Integer) -redisAddXPubTxs _ [] = return (pure 0) -redisAddXPubTxs xpub btxs = - zadd (txSetPfx <> encode xpub) $ - map (\t -> (blockRefScore t.block, encode t.txid)) btxs - --- | Redis command to remove transactions from an xpub. -redisRemXPubTxs :: - (Applicative f, RedisCtx m f) => XPubSpec -> [TxHash] -> m (f Integer) -redisRemXPubTxs xpub txhs = - case NonEmpty.nonEmpty txhs of - Nothing -> return (pure 0) - Just txhs' -> zrem (txSetPfx <> encode xpub) (NonEmpty.map encode txhs') - --- | Redis command to add unspent outputs to an xpub. -redisAddXPubUnspents :: - (Applicative f, RedisCtx m f) => - XPubSpec -> - [(OutPoint, BlockRef)] -> - m (f Integer) -redisAddXPubUnspents _ [] = - return (pure 0) -redisAddXPubUnspents xpub utxo = - zadd (utxoPfx <> encode xpub) $ - map (\(p, r) -> (blockRefScore r, encode p)) utxo - --- | Redis command to remove unspent outputs from an xpub. -redisRemXPubUnspents :: - (Applicative f, RedisCtx m f) => XPubSpec -> [OutPoint] -> m (f Integer) -redisRemXPubUnspents _ [] = - return (pure 0) -redisRemXPubUnspents xpub ops = - case NonEmpty.nonEmpty ops of - Nothing -> return (pure 0) - Just ops' -> zrem (utxoPfx <> encode xpub) (NonEmpty.map encode ops') - --- | Redis commands to set balances of an xpub and record its addresses. -redisAddXPubBalances :: - (Monad f, RedisCtx m f) => XPubSpec -> [XPubBal] -> m (f ()) -redisAddXPubBalances xpub bals = - case NonEmpty.nonEmpty bals of - Nothing -> return (pure ()) - Just bals' -> do - let bs = NonEmpty.map (\b -> (encode b.path, encode b.balance)) bals' - Redis.hset (balancesPfx <> encode xpub) bs - ys <- forM bals' $ \b -> - redisSetAddrInfo - b.balance.address - AddressXPub - { spec = xpub, - path = b.path - } - return $ sequence_ ys - --- | Redis command to set the last block processed by the cache. -redisSetHead :: (RedisCtx m f) => BlockHash -> m (f Redis.Status) -redisSetHead bh = Redis.set bestBlockKey (encode bh) - --- | Redis commands to read the xpub and path of addresses. -redisGetAddrsInfo :: - (Monad f, RedisCtx m f) => [Address] -> m (f [Maybe AddressXPub]) -redisGetAddrsInfo [] = return (pure []) -redisGetAddrsInfo as = do - is <- mapM (\a -> Redis.get (addrPfx <> encode a)) as - return $ do - is' <- sequence is - return $ map (eitherToMaybe . decode =<<) is' - --- | Addresses to derive after a newly used address, so that the gap of unused --- addresses after the last used one on its chain is kept. -addrsToAdd :: - Ctx -> - KeyIndex -> - [XPubBal] -> - AddressXPub -> - [(Address, AddressXPub)] -addrsToAdd ctx gap xbals addrinfo - | null fbals = - [] - | not haschange = - zipWith f addrs list - <> zipWith f changeaddrs changelist - | otherwise = - zipWith f addrs list - where - haschange = any ((== 1) . (!! 0) . (.path)) xbals - f a p = (a, AddressXPub {spec = xpub, path = p}) - dchain = addrinfo.path !! 0 - fbals = filter ((== dchain) . (!! 0) . (.path)) xbals - maxidx = maximum (map ((!! 1) . (.path)) fbals) - xpub = addrinfo.spec - aidx = addrinfo.path !! 1 - ixs = - if gap > maxidx - aidx - then [maxidx + 1 .. aidx + gap] - else [] - paths = map (Deriv :/ dchain :/) ixs - keys = map (\p -> derivePubPath ctx p xpub.key) - list = map pathToList paths - xpubf = xPubAddrFunction ctx xpub.deriv - addrs = map xpubf (keys paths) - changepaths = map (Deriv :/ 1 :/) [0 .. gap - 1] - changeaddrs = map xpubf (keys changepaths) - changelist = map pathToList changepaths - --- | Sort transactions so that each comes after those it spends. -sortTxData :: [TxData] -> [TxData] -sortTxData tds = - let txm = Map.fromList (map (\d -> (txHash d.tx, d)) tds) - ths = map (txHash . snd) (sortTxs (map (.tx) tds)) - in mapMaybe (`Map.lookup` txm) ths - --- | Addresses and outpoints of the outputs spent by a transaction. -txInputs :: Network -> Ctx -> TxData -> [(Address, OutPoint)] -txInputs net ctx td = - let is = td.tx.inputs - ps = I.toAscList td.prevs - as = map (scriptToAddressBS net ctx . (.script) . snd) ps - f (Right a) i = Just (a, i.outpoint) - f (Left _) _ = Nothing - in catMaybes (zipWith f as is) - --- | Addresses and outpoints of the outputs of a transaction. -txOutputs :: Network -> Ctx -> TxData -> [(Address, OutPoint)] -txOutputs net ctx td = - let ps = - zipWith - ( \i _ -> - OutPoint - { hash = txHash td.tx, - index = i - } - ) - [0 ..] - td.tx.outputs - as = map (scriptToAddressBS net ctx . (.script)) td.tx.outputs - f (Right a) p = Just (a, p) - f (Left _) _ = Nothing - in catMaybes (zipWith f as ps) - --- | Redis command to read the last block processed by the cache. -redisGetHead :: (Functor f, RedisCtx m f) => m (f (Maybe BlockHash)) -redisGetHead = do - x <- Redis.get bestBlockKey - return $ (eitherToMaybe . decode =<<) <$> x - --- | Redis command to read the mempool set, newest first. -redisGetMempool :: (Applicative f, RedisCtx m f) => m (f [(UnixTime, TxHash)]) -redisGetMempool = do - xs <- getFromSortedSet mempoolSetKey Nothing 0 0 - return $ map (uncurry f) <$> xs - where - f t s = ((scoreBlockRef s).timestamp, t) - --- | Text form of an xpub for logs, with a suffix for its address type. -xpubText :: - (StoreReadBase m) => - XPubSpec -> - CacheX m Text -xpubText xpub = do - net <- lift getNetwork - let suffix = case xpub.deriv of - DeriveNormal -> "" - DeriveP2SH -> "/p2sh" - DeriveP2WPKH -> "/p2wpkh" - ctx <- lift getCtx - return . cs $ suffix <> xPubExport net ctx xpub.key - --- | Tell the cache writer that a new block was imported. -cacheNewBlock :: (MonadIO m) => CacheWriter -> m () -cacheNewBlock = send CacheNewBlock - --- | Tell the cache writer that a mempool transaction was added or removed. -cacheNewTx :: (MonadIO m) => TxHash -> CacheWriter -> m () -cacheNewTx = send . CacheNewTx - --- | Ask the cache writer to sync the mempool, and wait until it is done. -cacheSyncMempool :: (MonadIO m) => CacheWriter -> m () -cacheSyncMempool = query CacheSyncMempool +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-ambiguous-fields #-} + +-- | +-- Module : Haskoin.Store.Cache +-- Copyright : (c) Haskoin Developers +-- License : MIT +-- Maintainer : jprupp@protonmail.ch +-- Stability : experimental +-- Portability : POSIX +-- +-- Redis cache of extended public keys (xpubs), shared by several stores. +-- +-- An xpub with many used addresses is slow to answer from the database: every +-- address has to be derived and read. Wallets of exchanges and payment +-- processors are like that, and are asked about all the time. The cache keeps +-- everything that the web server needs to answer about such an xpub in Redis: +-- the balances of its addresses up to the gap, its transactions, its unspent +-- outputs, and the bodies of its transactions with who spends their outputs. +-- +-- = One source of truth +-- +-- The data of a cached xpub always comes from the database, read with the +-- same functions that answer uncached queries +-- ("Haskoin.Store.Database.Query"), and is never computed from what the +-- cache guesses a change did, as the cache that this one replaced did, and +-- drifted. Whenever a block or a mempool transaction touches one of its +-- addresses, or a reorganisation changes one of its transactions, the store +-- that saw it reads from the database what that change affects, the +-- transactions and the outputs they create and spend, and writes the +-- differences in one atomic step ('cacheRefresh'). It reads the whole xpub +-- instead when it caches it, and whenever it cannot be sure that the entry +-- has every earlier change: checks against the balances of every address of +-- the xpub, and a full reload every ten minutes, keep a missed change from +-- staying. Reloads of one xpub are coalesced, so a burst of payments costs at +-- most one reload in progress and one waiting. +-- +-- Everything a response needs is in Redis, including the bodies of the +-- transactions: a store that has not yet seen a transaction of a cached xpub +-- still serves it in full. Bodies are kept once per transaction and shared by +-- the xpubs that refer to them; the last xpub to let go of one deletes it. +-- Bodies are stored without the spenders of their outputs, which change +-- without touching the xpub (an output paying someone else is spent by a +-- transaction that has nothing to do with the xpub). The spenders are in a +-- separate hash per transaction, kept up to date by every store as it imports +-- transactions, and filled in when a body is read. +-- +-- = Several stores, one Redis +-- +-- Stores index the same chain at slightly different times, and see mempool +-- transactions in different orders. Three rules keep them from getting in +-- each other's way: +-- +-- * __Each change is applied once.__ A store claims each change it sees, per +-- cached xpub that it touches (@ev:\:\@). The first store to +-- claim it reloads the xpub and marks the claim done; the others skip it. A +-- store that is catching up finds its events done and does no work, and a +-- store whose database does not have the best header ignores events +-- altogether. +-- +-- * __No store writes what knows less than Redis.__ A store does not replace +-- an entry stamped with a higher block than its own best block, nor one +-- with a transaction that its database has never seen; it gives the change +-- up for a store that knows more. So stores never undo each other's work. +-- +-- * __No entry refers to what Redis does not have.__ An entry is written in +-- one Lua script together with the bodies it needs, and the script writes +-- nothing if a body would be missing. A store that is behind can serve a +-- cached xpub in full, transactions it has not imported included. Bodies +-- that Redis already has are rewritten just before, in small scripts, so +-- that a large block does not hold Redis for long; a body may so be a +-- moment newer than an entry that has it, never older. +-- +-- The first two rules are the pure decisions of +-- "Haskoin.Store.Cache.Protocol", where a model test checks them with several +-- stores catching up in random interleavings. +-- +-- A lock per xpub keeps two stores from reloading it at the same time, and +-- every change of several keys of an entry is a Lua script, so readers never +-- see half of one. Stores that answer from Redis serve the same data; stores whose +-- databases disagree can still give different answers for xpubs that are not +-- cached. +-- +-- = Keys +-- +-- Every key starts with @hs2:\:@, so this cache can share a Redis with +-- the cache of older versions of the store, whose keys have no such prefix, +-- and with stores of other networks. +-- +-- * @x:\:meta@: hash with the serialized xpub (@spec@), the height of +-- the best block it was read at (@height@), the format version (@ver@, +-- now 3), the generation of the entry (@gen@), which every reload +-- increments, and the time of its last full reload in milliseconds +-- (@full@). +-- @\@ is the hexadecimal of the first 16 bytes of the SHA-256 of the +-- serialized xpub. +-- * @x:\:bal@: balances of the addresses up to the gap, serialized. +-- * @x:\:txs@: sorted set of transaction hashes, scored by 'blockRefScore'. +-- * @x:\:utxo@: sorted set of serialized unspent outputs, scored the same. +-- * @x:\:uop@: hash of serialized outpoint to its member of @utxo@, so +-- that an output can be removed by its outpoint alone, though its member +-- changes with its block. Entries of version 2 have none; their next full +-- reload builds it. +-- * @x:\:addrs@: set of the addresses of the balances. +-- * @a:\@: set of the ids of the cached xpubs with this address. +-- * @tx:\@: transaction body, serialized 'TxData' without spenders. +-- * @sp:\@: hash of output index to spender. +-- * @txref:\@: set of the ids of the cached xpubs with this transaction. +-- * @lru@: sorted set of ids by time of last use, for eviction. +-- * @lock:\@: lock held while an xpub is reloaded. +-- * @ev:\:\@: claim of a change of a cached xpub: @busy@ while a +-- store applies it, for two minutes at most, then @done@ for an hour. +module Haskoin.Store.Cache + ( -- * Running the cache + Cache, + CacheConfig (..), + withCache, + cacheAlive, + + -- * Reading + cacheXPubBals, + cacheXPubTxs, + cacheXPubTxCount, + cacheXPubUnspents, + cacheTxData, + cacheIsCached, + CacheCounters (..), + cacheCounters, + + -- * Changing + cacheRequest, + Reload (..), + cacheRefresh, + cacheDelete, + cacheEvict, + + -- * Internals + + -- | Exported for tests. + cachePrefix, + xpubId, + blockRefScore, + scoreBlockRef, + fullReloadEvery, + fullReloadAfter, + ) +where + +import Control.Monad (forM, forM_, join, unless, void, when) +import Data.Bits (shift, (.&.), (.|.)) +import Data.ByteString (ByteString) +import Data.ByteString qualified as BS +import Data.ByteString.Char8 qualified as C8 +import Data.Either (rights) +import Data.FileEmbed (embedFile, makeRelativeToProject) +import Data.Functor ((<&>)) +import Data.HashMap.Strict (HashMap) +import Data.HashMap.Strict qualified as HashMap +import Data.HashSet (HashSet) +import Data.HashSet qualified as HashSet +import Data.IntMap.Strict qualified as IntMap +import Data.List (nub) +import Data.List.NonEmpty qualified as NonEmpty +import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, maybeToList) +import Data.Serialize (decode, encode) +import Data.String.Conversions (cs) +import Data.Text (Text) +import Data.Time.Clock.POSIX (getPOSIXTime) +import Data.Word (Word32, Word64) +import Database.Redis (Connection, Redis, Reply) +import Database.Redis qualified as R +import Haskoin + ( Address, + BlockHash, + BlockHeader (..), + BlockNode (..), + Network (..), + OutPoint (..), + Tx (..), + TxHash, + TxIn (..), + TxOut (..), + encodeHex, + headerHash, + scriptToAddressBS, + sha256, + txHash, + ) +import Haskoin.Node (Chain, LogLevel (..), Logger, chainGetBest, logAt) +import Haskoin.Store.Cache.Protocol + ( Claim (..), + OnClaim (..), + OnReload (..), + Reload (..), + afterClaim, + afterReload, + mayReplace, + ) +import Haskoin.Store.Common (Limits (..), Start (..), StoreEvent (..), loopForever) +import Haskoin.Store.Data +import Haskoin.Store.Database.Query qualified as Q +import Haskoin.Store.Database.Query.Layered qualified as L +import Haskoin.Store.Database.Reader (DatabaseReader (..)) +import NQE (Inbox, Publisher, receive, withSubscription) +import System.Metrics.StatsD + ( StatCounter, + StatTiming, + Stats, + addTiming, + incrementCounter, + newStatCounter, + newStatTiming, + ) +import System.Random (randomIO) +import Text.Read (readMaybe) +import UnliftIO + ( IORef, + TVar, + atomicModifyIORef', + atomically, + checkSTM, + handleAny, + link, + modifyTVar', + newIORef, + newTVarIO, + pooledForConcurrentlyN_, + readIORef, + readTVar, + timeout, + tryAny, + withAsync, + writeIORef, + writeTVar, + ) +import UnliftIO.Concurrent (forkIO, threadDelay) + +-- | Settings of the cache. +data CacheConfig = CacheConfig + { -- | Redis URL, such as @redis:\/\/localhost:6379@; empty for the default + url :: !String, + -- | cache xpubs with at least this many used addresses + minAddrs :: !Int, + -- | or with at least this many transactions in their addresses + minTxs :: !Int, + -- | evict the least recently used xpubs past this many + maxXPubs :: !Int, + -- | StatsD client, to report the metrics of the cache + stats :: !(Maybe Stats) + } + +-- | StatsD metrics of the cache. +data CacheMetrics = CacheMetrics + { -- | xpubs answered from the cache (@cache.hits@) + hits :: !StatCounter, + -- | xpubs asked about that were not cached (@cache.misses@) + misses :: !StatCounter, + -- | xpubs read again from the database and written (@cache.reloads@) + reloads :: !StatCounter, + -- | reloads refused because the cache had newer data (@cache.stale@) + stale :: !StatCounter, + -- | xpubs evicted (@cache.evictions@) + evictions :: !StatCounter, + -- | reloads that read the whole xpub rather than what changed + -- (@cache.full_reloads@) + fullReloads :: !StatCounter, + -- | milliseconds to reload an xpub (@cache.reload@) + reloadTime :: !StatTiming + } + +-- | Register the metrics of the cache. +newCacheMetrics :: Stats -> IO CacheMetrics +newCacheMetrics s = do + hits <- c "hits" + misses <- c "misses" + reloads <- c "reloads" + stale <- c "stale" + evictions <- c "evictions" + fullReloads <- c "full_reloads" + reloadTime <- newStatTiming s "cache.reload" 10 + return CacheMetrics {..} + where + c x = newStatCounter s ("cache." <> x) 10 + +-- | Read the database through a view of it as it is now: the mempool is +-- kept apart from the chain and laid over it when read, and the two have to +-- be read as they were at one moment +-- ("Haskoin.Store.Database.Query.Layered"). Transactions that left the +-- mempool unconfirmed are among what these reads give, marked as deleted: +-- the cache has to hear of them to take them out. +viewed :: Cache -> (L.View -> IO a) -> IO a +viewed c = L.withView c.db + +-- | A running cache. +data Cache = Cache + { redis :: !Connection, + prefix :: !ByteString, + db :: !DatabaseReader, + chain :: !Chain, + minAddrs :: !Int, + minTxs :: !Int, + maxXPubs :: !Int, + logger :: !Logger, + metrics :: !(Maybe CacheMetrics), + -- | what this store did to the cache since it started + counters :: !(IORef CacheCounters), + -- | work for the worker, newest first + jobs :: !(TVar [Job]), + -- | when this store last marked each xpub as used, by id, in + -- milliseconds; see 'touchEvery' + touched :: !(IORef (HashMap ByteString Integer)), + -- | transactions that this store deleted since it started, as far as + -- the cache heard of them, up to a hundred thousand. The database + -- keeps nothing of a deleted transaction, so without this one that + -- Redis has and the database does not could as well be one that this + -- store has not seen yet, which an entry must not lose. + lost :: !(IORef (HashSet TxHash)) + } + +-- | What a store did to the cache since it started. +data CacheCounters = CacheCounters + { -- | xpubs read again from the database and written + reloads :: !Int, + -- | reloads given up because Redis knew more + behind :: !Int, + -- | reloads that read the whole xpub rather than what changed + fullReloads :: !Int + } + deriving (Eq, Show) + +-- | What this store did to the cache since it started. +cacheCounters :: Cache -> IO CacheCounters +cacheCounters c = readIORef c.counters + +-- | Work for the worker of the cache. +data Job + = -- | an event of the store, which may change cached xpubs + JobEvent !StoreEvent + | -- | cache an xpub that was asked about + JobCache !XPubSpec + | -- | try again to claim changes of an xpub that another store was busy + -- with: the transactions that changed it, and the claims + JobClaim !XPubSpec !(HashSet TxHash) ![ByteString] + | -- | reload an xpub for changes whose claims this store holds + JobHeld !XPubSpec !(HashSet TxHash) ![ByteString] + +-- | Connect to Redis and run the process that keeps the cache up to date with +-- the events of the store, while an action runs. +withCache :: + CacheConfig -> + DatabaseReader -> + Chain -> + Publisher StoreEvent -> + Logger -> + (Cache -> IO a) -> + IO a +withCache cfg db chain pub logger action = do + info <- + if null cfg.url + then return R.defaultConnectInfo + else either fail return (R.parseConnectInfo cfg.url) + conn <- R.checkedConnect info + jobs <- newTVarIO [] + counters <- newIORef (CacheCounters 0 0 0) + touched <- newIORef HashMap.empty + lost <- newIORef HashSet.empty + metrics <- mapM newCacheMetrics cfg.stats + let cache = + Cache + { redis = conn, + prefix = cachePrefix db.net, + db = db, + chain = chain, + minAddrs = cfg.minAddrs, + minTxs = cfg.minTxs, + maxXPubs = cfg.maxXPubs, + logger = logger, + metrics = metrics, + counters = counters, + jobs = jobs, + touched = touched, + lost = lost + } + withSubscription pub $ \events -> + withAsync (listener cache events) $ \a1 -> + withAsync (worker cache) $ \a2 -> do + link a1 + link a2 + action cache + +-- | Prefix of every key of the cache for a network. +cachePrefix :: Network -> ByteString +cachePrefix net = "hs2:" <> C8.pack net.name <> ":" + +-- | Identifier of an xpub in the keys. +xpubId :: XPubSpec -> ByteString +xpubId = cs . encodeHex . BS.take 16 . encode . sha256 . encode + +xkey :: Cache -> XPubSpec -> ByteString -> ByteString +xkey c x suffix = c.prefix <> "x:" <> xpubId x <> ":" <> suffix + +txKey :: Cache -> TxHash -> ByteString +txKey c h = c.prefix <> "tx:" <> encode h + +spKey :: Cache -> TxHash -> ByteString +spKey c h = c.prefix <> "sp:" <> encode h + +addrKey :: Cache -> Address -> ByteString +addrKey c a = c.prefix <> "a:" <> encode a + +lruKey :: Cache -> ByteString +lruKey c = c.prefix <> "lru" + +-- | Count something in the metrics, if they are enabled. +count :: Cache -> (CacheMetrics -> StatCounter) -> Int -> IO () +count c f n = mapM_ (\m -> incrementCounter (f m) n) c.metrics + +log' :: Cache -> LogLevel -> Text -> IO () +log' c l = logAt l c.logger + +-- | Whether Redis answers a ping within two seconds. The health check of +-- the web server asks, so that a store whose Redis is gone says that it is +-- answering from its own database alone. +cacheAlive :: Cache -> IO Bool +cacheAlive c = + handleAny (\_ -> return False) $ + timeout 2000000 (R.runRedis c.redis R.ping) <&> \case + Just (Right _) -> True + _ -> False + +-- | Run Redis commands, throwing if Redis answers with an error. +run :: Cache -> Redis (Either Reply a) -> IO a +run c f = + R.runRedis c.redis f >>= \case + Right x -> return x + Left e -> fail ("Redis error: " <> show e) + +------------------------------------------------------------------------------- +-- Scores +------------------------------------------------------------------------------- + +-- | Score of a position in a Redis sorted set, such that sorting by score +-- ascending sorts from newest to oldest. Mempool transactions get negative +-- scores from their time, so they come first; confirmed ones get positive +-- scores that decrease with height and position. Height and position are +-- packed into the 53 bits that a double holds exactly. +-- +-- Between equal scores Redis orders members by their bytes, which for +-- transaction hashes and unspent outputs is the order that the database uses +-- ('Haskoin.Store.Common.txRefKey', 'Haskoin.Store.Common.unspentKey'), so a +-- cached page is the page the database gives. +blockRefScore :: BlockRef -> Double +blockRefScore BlockRef {height = h, position = p} = + fromIntegral (0x001fffffffffffff - (h' .|. p')) + where + h' = (fromIntegral h .&. 0x07ffffff) `shift` 26 :: Word64 + p' = (fromIntegral p .&. 0x03ffffff) :: Word64 +blockRefScore MemRef {timestamp = t} = negate t' + where + t' = fromIntegral (t .&. 0x001fffffffffffff) + +-- | Inverse of 'blockRefScore'. +scoreBlockRef :: Double -> BlockRef +scoreBlockRef s + | s < 0 = MemRef {timestamp = n} + | otherwise = BlockRef {height = h, position = p} + where + n = truncate (abs s) :: Word64 + m = 0x001fffffffffffff - n + h = fromIntegral (m `shift` (-26)) + p = fromIntegral (m .&. 0x03ffffff) + +------------------------------------------------------------------------------- +-- Reading +------------------------------------------------------------------------------- + +-- | Balances of a cached xpub, or 'Nothing' if it is not cached. Marks the +-- xpub as used. An entry that cannot be decoded is deleted and counts as not +-- cached. +cacheXPubBals :: Cache -> XPubSpec -> IO (Maybe [XPubBal]) +cacheXPubBals c x = do + touch <- touchArgs c x + r <- run c $ do + b <- R.get (xkey c x "bal") + -- marking an xpub that is not cached is harmless: eviction removes it + forM_ touch $ \now -> R.zadd (lruKey c) [(fromIntegral now, xpubId x)] + return b + case r of + Nothing -> count c (.misses) 1 >> return Nothing + Just bs -> case decode bs of + Right bals -> count c (.hits) 1 >> return (Just bals) + Left _ -> do + count c (.misses) 1 + log' c LevelWarn "Cached xpub balances cannot be decoded; deleting them" + void (cacheDelete c x) + return Nothing + +-- | Whether an xpub is cached. +cacheIsCached :: Cache -> XPubSpec -> IO Bool +cacheIsCached c x = run c (R.exists (xkey c x "meta")) + +-- | Number of transactions of a cached xpub. +cacheXPubTxCount :: Cache -> XPubSpec -> IO (Maybe Word32) +cacheXPubTxCount c x = do + touch <- touchArgs c x + -- sent together, in one round trip + (cached, n) <- run c $ do + e <- R.exists (xkey c x "meta") + z <- R.zcard (xkey c x "txs") + forM_ touch $ \now -> R.zadd (lruKey c) [(fromIntegral now, xpubId x)] + return ((,) <$> e <*> z) + return (if cached then Just (fromIntegral n) else Nothing) + +-- | Page of the transactions of a cached xpub, newest first, as the database +-- would give it. +cacheXPubTxs :: Cache -> XPubSpec -> Limits -> IO (Maybe [TxRef]) +cacheXPubTxs c x limits = do + xs <- page c x "txs" limits (\th -> (0, encode th)) + return $ xs <&> \ys -> [TxRef {txid = t, block = scoreBlockRef sc} | (bs, sc) <- ys, Right t <- [decode bs]] + +-- | Page of the unspent outputs of a cached xpub, newest first, given its +-- balances, which give the paths of the addresses. +cacheXPubUnspents :: Cache -> XPubSpec -> [XPubBal] -> Limits -> IO (Maybe [XPubUnspent]) +cacheXPubUnspents c x bals limits = do + -- members are serialized unspent outputs: their block position, which is + -- nine bytes long, then their output point + xs <- page c x "utxo" limits (\th -> (9, encode (OutPoint th 0))) + let paths = HashMap.fromList [(b.balance.address, b.path) | b <- bals] + return $ + xs <&> \ys -> + [ XPubUnspent {unspent = u, path = p} + | (bs, _) <- ys, + Right u <- [decode bs], + Just a <- [u.address], + Just p <- [HashMap.lookup a paths] + ] + +-- | How often a store marks an xpub as used, in milliseconds. Marking it on +-- every read would make every read a write; eviction only needs to know +-- which xpubs were used recently. +touchEvery :: Integer +touchEvery = 10000 + +-- | The time to mark an xpub as used with, if this store has not marked it +-- in the last 'touchEvery' milliseconds. +touchArgs :: Cache -> XPubSpec -> IO (Maybe Integer) +touchArgs c x = do + now <- nowMs + atomicModifyIORef' c.touched $ \m -> + case HashMap.lookup (xpubId x) m of + Just t | now - t < touchEvery -> (m, Nothing) + _ -> + -- forget everything now and then, so that the map stays small + let m' = if HashMap.size m > 100000 then HashMap.empty else m + in (HashMap.insert (xpubId x) now m', Just now) + +-- | A page of a sorted set of a cached xpub, with the scores of its members, +-- or 'Nothing' if the xpub is not cached. One round trip to Redis: the +-- script finds where the page starts, as the database would, and marks the +-- xpub as used if it is time to. +-- +-- A page that starts at a transaction starts at its position, which is the +-- score of the transaction in the sorted set of transactions of the xpub. +-- Members of the same score whose bytes, after a number of bytes, sort +-- before the bytes that the function gives for the transaction are skipped, +-- as the database skips them. A start transaction that is not in the xpub is +-- looked up in Redis or in the database, in a second round trip; a page +-- with a start that is found nowhere is empty. +page :: + Cache -> + XPubSpec -> + ByteString -> + Limits -> + (TxHash -> (Int, ByteString)) -> + IO (Maybe [(ByteString, Double)]) +page c x set limits tieBytes = do + touch <- touchArgs c x + let common = + [ xkey c x "meta", + xkey c x set, + xkey c x "txs", + lruKey c, + maybe "" num touch, + xpubId x, + num limits.offset, + num limits.limit + ] + call extra = run c (R.eval pageScript [] (common <> extra)) + r <- case limits.start of + Nothing -> call ["top"] + Just (AtBlock h) -> call ["score", num' (blockRefScore (BlockRef h maxBound))] + Just (AtTx th) -> do + let (skip, bytes) = tieBytes th + call ["tx", encode th, num skip, bytes] >>= \case + ["nostart"] -> + startOf th >>= \case + Nothing -> return ["ok"] + Just ref -> call ["at", num' (blockRefScore ref), num skip, bytes] + y -> return y + case r of + "ok" : rest -> return (Just (pairs rest)) + _ -> return Nothing + where + pairs (m : sc : rest) | Just d <- readMaybe (C8.unpack sc) = (m, d) : pairs rest + pairs _ = [] + startOf th = + cacheTxData c [th] >>= \case + [Just td] -> return (Just td.block) + _ -> fmap (.block) <$> viewed c (\v -> L.getTxData v th) + +-- | Bodies of transactions that Redis has, in the order of the hashes, with +-- the spenders of their outputs filled in. 'Nothing' for those it does not +-- have. +cacheTxData :: Cache -> [TxHash] -> IO [Maybe TxData] +cacheTxData _ [] = return [] +cacheTxData c hs = do + bodies <- run c (R.mget (NonEmpty.fromList (map (txKey c) hs))) + spenders <- run c $ do + rs <- forM (zip hs bodies) $ \(h, b) -> + if isJust b then fmap Just <$> R.hgetall (spKey c h) else return (pure Nothing) + return (sequence rs) + return (zipWith fill bodies spenders) + where + fill (Just b) sp + | Right td <- decode b = + let ss = + IntMap.fromList + [ (fromIntegral i, s) + | (k, v) <- fromMaybe [] sp, + Right (i :: Word32) <- [decode k], + Right s <- [decode v] + ] + in Just (td :: TxData) {spenders = ss} + fill _ _ = Nothing + +------------------------------------------------------------------------------- +-- Changing +------------------------------------------------------------------------------- + +-- | Cache an xpub that was just read from the database, if it has enough +-- used addresses, or enough transactions: a wallet that reuses a few +-- addresses for many payments is as slow to read from the database as one +-- with many addresses. Transactions are counted per address, so one that +-- touches two addresses counts twice, which is close enough to decide. The +-- xpub is loaded in the background; the caller keeps the answer it has. +cacheRequest :: Cache -> XPubSpec -> [XPubBal] -> IO () +cacheRequest c x bals = + when (length used >= c.minAddrs || sum (map (.balance.txs) used) >= fromIntegral c.minTxs) $ + push c (JobCache x) + where + used = filter (not . nullBalance . (.balance)) bals + +-- | Give the worker something to do. +push :: Cache -> Job -> IO () +push c j = atomically (modifyTVar' c.jobs (j :)) + +-- | Give the worker something to do in two seconds. +later :: Cache -> Job -> IO () +later c j = void . forkIO $ threadDelay 2000000 >> push c j + +-- | Remove an xpub from the cache. Returns whether it was cached. +cacheDelete :: Cache -> XPubSpec -> IO Bool +cacheDelete c x = do + r <- run c (R.eval deleteScript [] [c.prefix, xpubId x]) + return (r == (1 :: Integer)) + +-- | Evict the least recently used xpubs until at most the given number are +-- cached. Returns how many were evicted. The cache does this by itself after +-- caching an xpub, down to its configured maximum. +cacheEvict :: Cache -> Int -> IO Int +cacheEvict c n = do + evicted <- fromInteger <$> run c (R.eval evictScript [] [c.prefix, num n]) + count c (.evictions) evicted + return evicted + +-- | Bring the entry of an xpub in Redis up to date with the database, unless +-- another store holds its lock or Redis knows more than this store (see +-- 'Reload'). The transactions given are the ones that changed it: their +-- bodies are written again even if Redis has them. +-- +-- A store never writes data that knows less than what is in Redis, so stores +-- that see the chain and the mempool at slightly different times do not undo +-- each other's work. Every body that the entry refers to is in Redis before +-- the entry is: the changes and the missing bodies are written in one Lua +-- script, which writes nothing if a body is missing, so a store that is +-- behind never finds a cached transaction that it cannot serve. Only the +-- differences are written, and the script writes nothing if the entry +-- changed since it was read (its generation), so Redis is held for the size +-- of the change, not of the xpub. Bodies that Redis already has, such as +-- those of the transactions that a block confirms, are rewritten first, in +-- small scripts ('rewriteBodies'), so that the confirmation of a large block +-- does not hold Redis in one long script. +-- +-- = Reading only what changed +-- +-- Working out the differences can take one of two paths. +-- +-- * __Incremental__ ('incrementalDiff'): only the transactions that changed +-- are read, with the outputs that they create and spend at addresses of +-- the xpub. The stress test (@stress\/results@) showed that reading the +-- whole xpub from both the database and Redis was almost all the time of a +-- reload, growing with the size of the xpub to seconds at 100,000 +-- transactions; the changes of one block or transaction are a few reads, +-- whatever the size of the xpub. +-- +-- * __Full__: the whole xpub is read from the database and from Redis, and +-- compared. This is what a first caching does, and the fallback whenever +-- the incremental path cannot be sure of its answer. +-- +-- The incremental path relies on every change of the xpub having been +-- applied to the entry, which is what the claims of events are for, but a +-- store can miss events: while it catches up, after a restart, or after an +-- error. So it is only taken when the entry shows no sign of having missed +-- one, and it checks its own result: +-- +-- * the entry is in the current format, stamped with the best block of this +-- store or the one before it (a larger gap means blocks it may have +-- missed), and was fully reloaded less than 'fullReloadAfter' ago; +-- +-- * the balances of every address of the xpub are read from the database, +-- which is cheap, a read per address; an address that no changed +-- transaction touches must have the balance that Redis has. Under load it +-- often does not, because the database is already ahead of the events +-- being applied, so the newer transactions of those addresses are added to +-- the changes first ('catchUp'), and only a balance that they do not +-- explain means a change was missed; +-- +-- * no address with transactions enters or leaves the gap, as its history +-- would have to be read whole. +-- +-- Otherwise the full path runs. A missed change that leaves every balance +-- as it was, such as the confirmation of a transaction that only spends from +-- the xpub, is the one thing the checks cannot see, and the regular full +-- reload bounds how long it can last. +cacheRefresh :: Cache -> XPubSpec -> HashSet TxHash -> IO Reload +cacheRefresh c x changed = + fromMaybe Locked <$> withLock c x (timed (go (3 :: Int) [])) + where + go tries extra = do + m <- readMeta c x + height <- bestHeight c + now <- nowMs + if not (mayReplace m.stamp height False) + then behind + else do + bals <- viewed c (\v -> L.xPubBals v x) + fast <- + if incremental m height now + then incrementalDiff c x changed m bals + else return Fallback + diff <- case fast of + Apply d -> return (Just d) + KnowsMore -> return Nothing + Fallback -> fullDiff c x changed m height bals now + case diff of + Nothing -> behind + Just d -> commit tries extra m height now bals d + commit tries extra m height now bals d = do + bodies <- catMaybes <$> viewed c (\v -> L.getManyTxData v (nub (extra <> d.wanted))) >>= rewriteBodies c + let args = + [c.prefix, xpubId x, num height, num now, encode x, encode bals, m.gen] + <> [if d.full then num now else ""] + <> counted d.addrAdd + <> counted d.addrDel + <> counted2 [(t, num' sc) | (t, sc) <- d.txAdd] + <> counted d.txDel + <> counted3 [(op, u, num' sc) | (op, u, sc) <- d.utxoAdd] + <> counted2 d.utxoDel + <> bodyArgs bodies + run c (R.eval commitScript [] args) >>= \case + ["ok"] -> do + void (cacheEvict c c.maxXPubs) + count c (.reloads) 1 + when d.full $ count c (.fullReloads) 1 + atomicModifyIORef' c.counters $ \k -> + ( k {reloads = k.reloads + 1, fullReloads = k.fullReloads + fromEnum d.full} :: CacheCounters, + () + ) + return Reloaded + ("missing" : missing) + | tries > 0 -> go (tries - 1) (rights (map decode missing)) + ["changed"] + | tries > 0 -> go (tries - 1) extra + _ -> behind + -- whether the entry may be brought up to date incrementally + incremental m height now = + m.ver == "3" + && not (HashSet.null changed) + && maybe False (\s -> toInteger height - s <= 1) m.stamp + && maybe False (\f -> now - f < fullReloadAfter x) m.full + behind = do + count c (.stale) 1 + atomicModifyIORef' c.counters (\k -> (k {behind = k.behind + 1} :: CacheCounters, ())) + return Behind + timed f = do + start <- nowMs + r <- f + end <- nowMs + forM_ c.metrics $ \m -> addTiming m.reloadTime (fromInteger (end - start)) + return r + +-- | Longest time, in milliseconds, between full reloads of an entry: ten +-- minutes; each xpub has its own interval up to this ('fullReloadAfter'). It +-- bounds how long a change that the checks of the incremental path cannot +-- see stays out of the cache. A full reload of the largest xpubs of the +-- stress test takes a few seconds and holds the xpub in memory while it +-- runs, so it is kept rare. +fullReloadEvery :: Integer +fullReloadEvery = 10 * 60 * 1000 + +-- | Time, in milliseconds, after its last full reload when an entry is read +-- whole again: between half of 'fullReloadEvery' and all of it, the same for +-- an xpub on every store, and different from one xpub to the next. +-- +-- With one interval for every entry, entries cached together are reloaded +-- whole together, every time. In the full stress test the four xpubs did so +-- every ten minutes, and the heap of the server went from under 100 MiB to +-- 785 MiB for a few seconds, holding all four at once. Each xpub gets its own +-- interval instead, so such entries drift apart from their first scheduled +-- full reload. It comes from the hash of the xpub, not from a random number, +-- so that it needs no state and every store sharing Redis agrees on it. +fullReloadAfter :: XPubSpec -> Integer +fullReloadAfter x = half + spread `mod` half + where + half = fullReloadEvery `div` 2 + spread = BS.foldl' (\a w -> a * 256 + toInteger w) 0 (BS.take 4 (encode (sha256 (encode x)))) + +-- | What to write to bring an entry up to date. Members of the sets are +-- serialized: addresses, transaction hashes, and unspent outputs, which go +-- with their outpoints. +data Diff = Diff + { addrAdd :: ![ByteString], + addrDel :: ![ByteString], + -- | transactions to add or move, with their scores + txAdd :: ![(ByteString, Double)], + txDel :: ![ByteString], + -- | unspent outputs to add, with their outpoints and scores + utxoAdd :: ![(ByteString, ByteString, Double)], + -- | outpoints of unspent outputs to remove, with the member if known; the + -- script finds it by its outpoint otherwise + utxoDel :: ![(ByteString, ByteString)], + -- | transactions whose bodies to write + wanted :: ![TxHash], + -- | whether the whole xpub was read, which the entry records + full :: !Bool + } + +-- | The outcome of trying the incremental path. +data Incremental + = -- | these are the differences + Apply !Diff + | -- | Redis has a changed transaction that this store has never seen + KnowsMore + | -- | the incremental path cannot be sure; read the whole xpub + Fallback + +-- | The differences of an entry from the transactions that changed and the +-- balances of the xpub, without reading its history; see 'cacheRefresh'. +-- +-- When the balances show that the database knows of changes beyond the ones +-- given, the newest transactions of the addresses whose balances moved are +-- added to them ('catchUp'), and the differences are worked out again; only +-- if that does not account for every balance does it fall back. +incrementalDiff :: Cache -> XPubSpec -> HashSet TxHash -> Meta -> [XPubBal] -> IO Incremental +incrementalDiff c x changed m bals = + case (decode m.bal :: Either String [XPubBal], m.stamp) of + (Right old, Just stamp) -> + incrementalFrom c x old bals changed >>= \case + Missed missed -> + catchUp c x stamp missed >>= \case + Just extra + | not (extra `HashSet.isSubsetOf` changed) -> + incrementalFrom c x old bals (changed <> extra) <&> \case + Missed _ -> Fallback + Settled r -> r + _ -> return Fallback + Settled r -> return r + _ -> return Fallback + +-- | The outcome of working out the differences from a set of changes. +data Attempt + = -- | the balances of these addresses moved, but no change touches them + Missed ![Address] + | Settled !Incremental + +-- | The differences of an entry from its old balances, its new ones, and the +-- transactions that changed it. +incrementalFrom :: Cache -> XPubSpec -> [XPubBal] -> [XPubBal] -> HashSet TxHash -> IO Attempt +incrementalFrom c x old bals changed = do + let hashes = HashSet.toList changed + stored <- viewed c (\v -> L.getManyTxData v hashes) + -- those that the database does not have because this store deleted + -- them count as known, and as deleted + gone <- readIORef c.lost + dropped <- lostTxs c [h | (h, Nothing) <- zip hashes stored, HashSet.member h gone] + let found = HashMap.fromList [(txHash td.tx, td) | td <- dropped] + tds = [maybe (HashMap.lookup h found) Just td | (h, td) <- zip hashes stored] + let newMap = HashMap.fromList [(b.balance.address, b.balance) | b <- bals] + oldMap = HashMap.fromList [(b.balance.address, b.balance) | b <- old] + entering = [b | (a, b) <- HashMap.toList newMap, not (HashMap.member a oldMap)] + leaving = [b | (a, b) <- HashMap.toList oldMap, not (HashMap.member a newMap)] + known = catMaybes tds + unknown = [h | (h, Nothing) <- zip hashes tds] + ours a = HashMap.member a newMap + touched = HashSet.fromList [a | td <- known, a <- txAddresses c td, ours a] + missed = + [ a + | (a, b) <- HashMap.toList newMap, + Just o <- [HashMap.lookup a oldMap], + o /= b, + not (HashSet.member a touched) + ] + if + | any (\b -> b.txs > 0) (entering <> leaving) -> return (Settled Fallback) + | not (null missed) -> return (Missed missed) + | otherwise -> do + inRedis <- run c (sequence <$> mapM (R.zscore (xkey c x "txs") . encode) unknown) + if any isJust inRedis + then return (Settled KnowsMore) + else do + let active td = not td.deleted && any ours (txAddresses c td) + ops = nub (concatMap (outpointsAt c ours) known) + us <- viewed c (\v -> mapM (L.getUnspent v) ops) + return . Settled . Apply $ + Diff + { addrAdd = [encode b.address | b <- entering], + addrDel = [encode b.address | b <- leaving], + txAdd = [(encode (txHash td.tx), blockRefScore td.block) | td <- known, active td], + txDel = [encode (txHash td.tx) | td <- known, not (active td)], + utxoAdd = [(encode op, encode u, blockRefScore u.block) | (op, Just u) <- zip ops us], + utxoDel = [(encode op, "") | (op, Nothing) <- zip ops us], + wanted = [txHash td.tx | td <- known, active td], + full = False + } + +-- | Changes of an entry that the database has and that it was not told of: +-- what a store finds when its database runs ahead of the events it is +-- applying, as it does under load, when the balances it reads after a batch +-- already include the transactions of the next. 'Nothing' if there are more +-- than 'catchUpMost', when reading the whole xpub is as cheap. +-- +-- The entry is stamped with a block that this store had whole, so what can +-- have changed since is: +-- +-- * transactions in the mempool or in a later block, which are first in the +-- index of an address, newest first, and are read from it for each address +-- whose balance moved, down to the stamp; +-- +-- * transactions in the mempool when the entry was written that have been +-- confirmed or dropped since, found from the mempool transactions of the +-- entry, which are few. +-- +-- A reorganisation that replaces the block of the stamp is not covered, and +-- the balances catch it: if the transactions found do not account for every +-- balance, the full path runs. +catchUp :: Cache -> XPubSpec -> Integer -> [Address] -> IO (Maybe (HashSet TxHash)) +catchUp c x stamp addrs = do + newer <- sequence <$> mapM addressNewer addrs + pool <- run c (R.zrangebyscoreLimit (xkey c x "txs") (-1 / 0) (-0.5) 0 (toInteger catchUpMost + 1)) + let poolHashes = rights (map decode pool) + tds <- viewed c (\v -> L.getManyTxData v poolHashes) + let settled = [h | (h, td) <- zip poolHashes tds, maybe True left td] + found = HashSet.fromList (settled <> concat (fromMaybe [] newer)) + return $ + if isNothing newer || length pool > catchUpMost || HashSet.size found > catchUpMost + then Nothing + else Just found + where + -- a mempool transaction of the entry that is no longer in the mempool + left td = td.deleted || not (isMem td.block) + isMem MemRef {} = True + isMem BlockRef {} = False + after t = case t.block of + MemRef {} -> True + BlockRef {height = h} -> toInteger h > stamp + chunk = 100 :: Word32 + addressNewer a = loop 0 [] + where + loop off acc = do + ts <- viewed c (\v -> L.getAddressTxs v a Limits {limit = chunk, offset = off, start = Nothing}) + let (new, rest) = span after ts + acc' = acc <> map (.txid) new + if + | length acc' > catchUpMost -> return Nothing + | not (null rest) || length ts < fromIntegral chunk -> return (Just acc') + | otherwise -> loop (off + chunk) acc' + +-- | Most transactions that 'catchUp' adds to the changes of a reload. Each +-- costs a few reads; a full reload of the xpubs of the stress test costs +-- tens of thousands. +catchUpMost :: Int +catchUpMost = 1000 + +-- | The differences of an entry from the whole xpub, read from the database +-- and from Redis. 'Nothing' if Redis has a transaction of the xpub that this +-- store has never seen. +fullDiff :: Cache -> XPubSpec -> HashSet TxHash -> Meta -> Word32 -> [XPubBal] -> Integer -> IO (Maybe Diff) +fullDiff c x changed m height bals _ = do + st <- readStored c x + txs <- viewed c (\v -> L.xPubTxs v bals def') + let newTxs = [(encode t.txid, blockRefScore t.block) | t <- txs] + newTxSet = HashSet.fromList (map fst newTxs) + txDel = [t | t <- HashMap.keys st.txs, not (HashSet.member t newTxSet)] + -- a transaction that Redis has and this store has never seen. The store + -- keeps nothing of a transaction that it deleted, so one that it does + -- not have is taken for deleted, and not for unseen, if the cache heard + -- of its deletion, or if the entry has it as unconfirmed for more than + -- ten minutes: a store that is in step with the others has seen a + -- transaction of the mempool by then, and one that is not does not get + -- here. + let asked = [(h, sc) | t <- txDel, Right h <- [decode t], Just sc <- [HashMap.lookup t st.txs]] + known <- viewed c (\v -> L.getManyTxData v (map fst asked)) + gone <- readIORef c.lost + now <- (`div` 1000) <$> nowMs + let stale sc = sc < 0 && fromIntegral now - negate sc > 600 + unseen = [h | ((h, sc), Nothing) <- zip asked known, not (HashSet.member h gone), not (stale sc)] + if not (mayReplace m.stamp height (not (null unseen))) + then return Nothing + else do + utxos <- viewed c (\v -> L.xPubUnspents v bals def') + let txAdd = [(t, sc) | (t, sc) <- newTxs, HashMap.lookup t st.txs /= Just sc] + newUs = [(encode u.unspent.outpoint, encode u.unspent, blockRefScore u.unspent.block) | u <- utxos] + newUSet = HashSet.fromList [u | (_, u, _) <- newUs] + -- an entry of an older format has no index of outpoints yet, so + -- every output is written, to build it + utxoAdd + | m.ver == "3" = [n | n@(_, u, _) <- newUs, not (HashSet.member u st.utxos)] + | otherwise = newUs + utxoDel = + [ (either (const "") (encode . (.outpoint)) (decode u :: Either String Unspent), u) + | u <- HashSet.toList st.utxos, + not (HashSet.member u newUSet) + ] + newAs = HashSet.fromList [encode b.balance.address | b <- bals] + return . Just $ + Diff + { addrAdd = [a | a <- HashSet.toList newAs, not (HashSet.member a st.addrs)], + addrDel = [a | a <- HashSet.toList st.addrs, not (HashSet.member a newAs)], + txAdd, + txDel, + utxoAdd, + utxoDel, + -- bodies of the transactions that are new or moved, and of those + -- that changed; the others are in Redis, kept there by this entry + wanted = + nub $ + [h | (t, _) <- txAdd, Right h <- [decode t]] + <> [t.txid | t <- txs, t.txid `HashSet.member` changed], + full = True + } + where + def' = Limits {limit = 0, offset = 0, start = Nothing} + +-- | Addresses that a transaction spends from or pays to. +txAddresses :: Cache -> TxData -> [Address] +txAddresses c td = + nub . rights $ + map (scriptToAddressBS c.db.net c.db.ctx . (.script)) (IntMap.elems td.prevs) + <> map (scriptToAddressBS c.db.net c.db.ctx . (.script)) td.tx.outputs + +-- | Outpoints whose unspent output a transaction may change at addresses that +-- pass a test: those it creates, and those it spends. +outpointsAt :: Cache -> (Address -> Bool) -> TxData -> [OutPoint] +outpointsAt c ours td = + [OutPoint (txHash td.tx) i | (i, o) <- zip [0 ..] td.tx.outputs, at o.script] + <> [ inp.outpoint + | (i, inp) <- zip [0 :: Int ..] td.tx.inputs, + Just prev <- [IntMap.lookup i td.prevs], + at prev.script + ] + where + at s = either (const False) ours (scriptToAddressBS c.db.net c.db.ctx s) + +-- | What a reload needs to know of an entry first: the height it is stamped +-- with, its generation, which every commit increments, the version of its +-- format, the time of its last full reload, and its balances, serialized. +data Meta = Meta + { stamp :: !(Maybe Integer), + gen :: !ByteString, + ver :: !ByteString, + full :: !(Maybe Integer), + bal :: !ByteString + } + +-- | Read what a reload needs to know of an entry, in one round trip. +readMeta :: Cache -> XPubSpec -> IO Meta +readMeta c x = do + (fs, b) <- run c $ do + fs <- R.hmget (xkey c x "meta") ("height" NonEmpty.:| ["gen", "ver", "full"]) + b <- R.get (xkey c x "bal") + return ((,) <$> fs <*> b) + let field k = join (lookup k (zip [0 :: Int ..] fs)) + number = (readMaybe . C8.unpack =<<) + return + Meta + { stamp = number (field 0), + gen = fromMaybe "" (field 1), + ver = fromMaybe "" (field 2), + full = number (field 3), + bal = fromMaybe "" b + } + +-- | The sets of an entry, as a full reload compares them with the database. +data Stored = Stored + { txs :: !(HashMap ByteString Double), + utxos :: !(HashSet ByteString), + addrs :: !(HashSet ByteString) + } + +-- | Read the sets of an entry. The sorted sets are read in chunks, so that +-- no command holds Redis for long however large the xpub. The chunks are not +-- read atomically, but nothing changes the entry while this store holds its +-- lock except deleting or evicting it, which changes its generation, and the +-- commit checks the generation. +readStored :: Cache -> XPubSpec -> IO Stored +readStored c x = do + as <- run c (R.smembers (xkey c x "addrs")) + ts <- chunks (\i j -> R.zrangeWithscores (xkey c x "txs") i j) + us <- chunks (\i j -> R.zrange (xkey c x "utxo") i j) + return + Stored + { txs = HashMap.fromList ts, + utxos = HashSet.fromList us, + addrs = HashSet.fromList as + } + where + size = 5000 :: Integer + chunks :: (Integer -> Integer -> Redis (Either Reply [a])) -> IO [a] + chunks f = loop 0 + where + loop i = do + xs <- run c (f i (i + size - 1)) + if toInteger (length xs) < size then return xs else (xs <>) <$> loop (i + size) + +-- | Rewrite the bodies that Redis already has, in scripts of 'bodyChunk' +-- bodies each, and give back the others, for the commit to write. +-- +-- A block confirms many transactions of a busy xpub at once, and each needs +-- its body written again, with its block and spenders. In one script, with +-- the scores and outputs of the entry, that held Redis for 10 to 30 ms at +-- the confirmation of each block in the stress test, while every other +-- client waited. Bodies are shared by every entry that has the transaction, +-- and are written whole from the database, so writing them before the entry +-- is safe: a body is never older than the entry that refers to it, which is +-- what matters (see 'cacheRefresh'), and other entries already see bodies +-- written by commits of other xpubs before their own. Only bodies that are +-- there are rewritten, so that a commit that then fails leaves nothing +-- behind; and if one goes between these scripts and the commit, the commit +-- reports it missing and is retried with it. +rewriteBodies :: Cache -> [TxData] -> IO [TxData] +rewriteBodies c tds = + fmap concat . forM (chunks tds) $ \ch -> do + absent <- HashSet.fromList <$> run c (R.eval bodiesScript [] (c.prefix : bodyArgs ch)) + return [td | td <- ch, encode (txHash td.tx) `HashSet.member` absent] + where + chunks [] = [] + chunks xs = let (a, b) = splitAt bodyChunk xs in a : chunks b + +-- | Bodies rewritten by one script of 'rewriteBodies': each is a few +-- commands, so a chunk holds Redis for a millisecond or two. +bodyChunk :: Int +bodyChunk = 200 + +-- | Arguments for bodies and their spenders: the number of bodies, the hash +-- and body of each, the number of spenders, and the transaction, output index +-- and spender of each. +bodyArgs :: [TxData] -> [ByteString] +bodyArgs tds = + counted2 [(encode (txHash td.tx), encode (td :: TxData) {spenders = IntMap.empty}) | td <- tds] + <> counted3 + [ (encode (txHash td.tx), encode (fromIntegral i :: Word32), encode s) + | td <- tds, + (i, s) <- IntMap.toList td.spenders + ] + +counted :: [ByteString] -> [ByteString] +counted xs = num (length xs) : xs + +counted2 :: [(ByteString, ByteString)] -> [ByteString] +counted2 xs = num (length xs) : concat [[a, b] | (a, b) <- xs] + +counted3 :: [(ByteString, ByteString, ByteString)] -> [ByteString] +counted3 xs = num (length xs) : concat [[a, b, d] | (a, b, d) <- xs] + +num :: (Integral a) => a -> ByteString +num = C8.pack . show . toInteger + +num' :: Double -> ByteString +num' = C8.pack . show + +nowMs :: IO Integer +nowMs = round . (* 1000) <$> getPOSIXTime + +-- | Height of the best block of the database, 0 if none. +bestHeight :: Cache -> IO Word32 +bestHeight c = + Q.getBestBlock c.db >>= \case + Nothing -> return 0 + Just h -> maybe 0 (.height) <$> Q.getBlock c.db h + +-- | Whether the database has the best header of the node. +inSync :: Cache -> IO Bool +inSync c = + Q.getBestBlock c.db >>= \case + Nothing -> return False + Just bb -> do + cb <- chainGetBest c.chain + return (cb.height > 0 && headerHash cb.header == bb) + +-- | Run an action holding the lock of an xpub. 'Nothing' if another store +-- holds it. The lock expires after two minutes in case its holder dies. +withLock :: Cache -> XPubSpec -> IO a -> IO (Maybe a) +withLock c x f = do + token <- C8.pack . show <$> (randomIO :: IO Word64) + let key = c.prefix <> "lock:" <> xpubId x + opts = + R.SetOpts + { R.setSeconds = Nothing, + R.setMilliseconds = Just 120000, + R.setUnixSeconds = Nothing, + R.setUnixMilliseconds = Nothing, + R.setCondition = Just R.Nx, + R.setKeepTTL = False + } + R.runRedis c.redis (R.setOpts key token opts) >>= \case + Right R.Ok -> do + r <- f + void (run c (R.eval unlockScript [key] [token] :: Redis (Either Reply Integer))) + return (Just r) + _ -> return Nothing + +------------------------------------------------------------------------------- +-- Keeping up with the store +------------------------------------------------------------------------------- + +-- | Do the work of the cache, forever. +-- +-- A store that is not in sync ignores events and requests: the stores that +-- are ahead have already done or will do the work, and this one would only +-- find that Redis knows more. Once in sync, each event is claimed per cached +-- xpub that it changes ('claim'): the first store to claim a change reloads +-- the xpub and marks the claim done, and the others skip it, so a change is +-- applied once however many stores share the Redis, and stores that catch up +-- find their events done. A change that a store could not apply because +-- Redis knew more is released for another store to take; one that another +-- store is busy with is looked at again later. +worker :: Cache -> IO () +worker c = do + lastBest <- newIORef Nothing + loopForever $ do + js <- atomically $ do + xs <- readTVar c.jobs + checkSTM (not (null xs)) + writeTVar c.jobs [] + return (reverse xs) + synced <- inSync c + if synced + then handleAny (\e -> log' c LevelError ("Cache: " <> cs (show e))) (work c lastBest js) + else releaseClaims c (concat [ks | JobHeld _ _ ks <- js]) + +-- | Do a batch of jobs. +work :: Cache -> IORef (Maybe BlockHash) -> [Job] -> IO () +work c lastBest js = do + fromEvents <- concat <$> mapM (eventChanges c lastBest) [e | JobEvent e <- js] + let toClaim = fromEvents <> [(k, x, ts) | JobClaim x ts ks <- js, k <- ks] + claimed <- fmap catMaybes . forM toClaim $ \(k, x, ts) -> + afterClaim <$> claim c k >>= \case + ReloadNow -> return (Just (x, (ts, [k]))) + Skip -> return Nothing + ClaimLater -> later c (JobClaim x ts [k]) >> return Nothing + let held = + HashMap.fromListWith + (\(a, b) (a', b') -> (a <> a', b <> b')) + (claimed <> [(x, (ts, ks)) | JobHeld x ts ks <- js]) + pooledForConcurrentlyN_ parallelReloads (HashMap.toList held) $ \(x, (ts, ks)) -> + afterReload <$> reload x ts >>= \case + Finish -> finishClaims c ks + Release -> releaseClaims c ks + Hold -> extendClaims c ks >> later c (JobHeld x ts ks) + pooledForConcurrentlyN_ parallelReloads (nub [x | JobCache x <- js, not (HashMap.member x held)]) $ \x -> + cacheIsCached c x >>= \case + True -> return () + False -> + reload x HashSet.empty >>= \case + Locked -> later c (JobCache x) + _ -> return () + where + reload x ts = + tryAny (cacheRefresh c x ts) >>= \case + Right r -> return r + Left e -> do + log' c LevelError ("Could not cache xpub: " <> cs (show e)) + return Locked + +-- | How many xpubs a store reloads at once. Each holds the lock of its xpub, +-- so two stores never reload the same one; reloading several at once keeps +-- one large xpub from holding up the others. +parallelReloads :: Int +parallelReloads = 4 + +-- | Changes that an event makes to cached xpubs: for each xpub, the key of +-- the claim for the change, and the transactions that make it. Also keeps the +-- spenders of cached transactions up to date, which is harmless to repeat. +eventChanges :: Cache -> IORef (Maybe BlockHash) -> StoreEvent -> IO [(ByteString, XPubSpec, HashSet TxHash)] +eventChanges c lastBest e = do + (name, tds) <- case e of + StoreBestBlock h -> do + prev <- readIORef lastBest + writeIORef lastBest (Just h) + ("b:" <> encode h,) <$> blockTxs c prev h + StoreMempoolNew t -> ("t+:" <> encode t,) . maybeToList <$> viewed c (\v -> L.getTxData v t) + -- the store keeps nothing of a transaction that it deleted. Redis has + -- the body of every transaction of a cached xpub, so if it does not + -- have this one, no entry does either + StoreMempoolDelete t -> do + noteLost c [t] + ("t-:" <> encode t,) <$> lostTxs c [t] + _ -> return ("", []) + if null tds + then return [] + else do + updateSpenders c tds + affected <- affectedXPubs c tds + return [(c.prefix <> "ev:" <> name <> ":" <> xpubId x, x, ts) | (x, ts) <- affected] + +-- | Claim a change. A claim is held for two minutes, so that a store that +-- dies while holding it does not keep others from the change for long. +claim :: Cache -> ByteString -> IO Claim +claim c k = do + let opts = + R.SetOpts + { R.setSeconds = Nothing, + R.setMilliseconds = Just 120000, + R.setUnixSeconds = Nothing, + R.setUnixMilliseconds = Nothing, + R.setCondition = Just R.Nx, + R.setKeepTTL = False + } + R.runRedis c.redis (R.setOpts k "busy" opts) >>= \case + Right R.Ok -> return Claimed + _ -> + run c (R.get k) <&> \case + Just "done" -> Done + _ -> Busy + +-- | Mark changes as applied, for an hour: long enough for every store in +-- sync to see the same events. +finishClaims :: Cache -> [ByteString] -> IO () +finishClaims _ [] = return () +finishClaims c ks = + void . run c $ sequence <$> mapM (\k -> R.setex k 3600 "done") ks + +-- | Give up changes, for another store to apply. +releaseClaims :: Cache -> [ByteString] -> IO () +releaseClaims _ [] = return () +releaseClaims c ks = void (run c (R.del (NonEmpty.fromList ks))) + +-- | Hold changes for another two minutes. +extendClaims :: Cache -> [ByteString] -> IO () +extendClaims _ [] = return () +extendClaims c ks = void . run c $ sequence <$> mapM (`R.pexpire` 120000) ks + +-- | Pass the events of the store that may change cached xpubs to the worker. +listener :: Cache -> Inbox StoreEvent -> IO () +listener c events = + loopForever $ + receive events >>= \case + e@StoreBestBlock {} -> push c (JobEvent e) + e@StoreMempoolNew {} -> push c (JobEvent e) + e@StoreMempoolDelete {} -> push c (JobEvent e) + _ -> return () + +-- | Transactions of a new best block, and of the blocks that a +-- reorganisation took out of the chain since the previous best block. +blockTxs :: Cache -> Maybe BlockHash -> BlockHash -> IO [TxData] +blockTxs c prev h = + Q.getBlock c.db h >>= \case + Nothing -> return [] + Just bd -> do + reverted <- case prev of + Just p | p /= bd.header.prev && p /= h -> walk p + _ -> return [] + let hashes = bd.txs <> reverted + found <- viewed c (\v -> L.getManyTxData v hashes) + -- a transaction of a reverted block that did not go back to the + -- mempool, as one that spends its coinbase does not, is gone from + -- the database. Redis has its body if a cached xpub has it. + let missing = [h' | (h', Nothing) <- zip hashes found] + noteLost c missing + (catMaybes found <>) <$> lostTxs c missing + where + -- blocks that are no longer in the main chain, from the old best block + walk p = + Q.getBlock c.db p >>= \case + Just b | not b.main -> (b.txs <>) <$> walk b.header.prev + _ -> return [] + +-- | Note that the store deleted transactions. +noteLost :: Cache -> [TxHash] -> IO () +noteLost _ [] = return () +noteLost c hs = atomicModifyIORef' c.lost $ \seen -> + let more = foldr HashSet.insert seen hs + in (if HashSet.size more > 100000 then HashSet.fromList hs else more, ()) + +-- | The bodies that Redis has of transactions that the store deleted, +-- marked as deleted. Redis has the body of every transaction of a cached +-- xpub, so one that it does not have is in no entry. +lostTxs :: Cache -> [TxHash] -> IO [TxData] +lostTxs c hs = map (\td -> (td :: TxData) {deleted = True}) . catMaybes <$> cacheTxData c hs + +-- | Cached xpubs with an address that these transactions spend from or pay +-- to, with the transactions that touch each. +affectedXPubs :: Cache -> [TxData] -> IO [(XPubSpec, HashSet TxHash)] +affectedXPubs c tds = do + let net = c.db.net + ctx = c.db.ctx + addrsOf :: TxData -> [Address] + addrsOf td = + nub . rights $ + map (scriptToAddressBS net ctx . (.script)) (IntMap.elems td.prevs) + <> map (scriptToAddressBS net ctx . (.script)) td.tx.outputs + byAddr = + HashMap.fromListWith (<>) [(a, HashSet.singleton (txHash td.tx)) | td <- tds, a <- addrsOf td] + addrs = HashMap.keys byAddr + ids <- run c (sequence <$> mapM (R.smembers . addrKey c) addrs) + let byId = + HashMap.fromListWith + (<>) + [(i, ts) | (a, is) <- zip addrs ids, i <- is, Just ts <- [HashMap.lookup a byAddr]] + spec i = R.hget (c.prefix <> "x:" <> i <> ":meta") "spec" + specs <- run c (sequence <$> mapM spec (HashMap.keys byId)) + return + [ (x, ts) + | (Just bs, ts) <- zip specs (HashMap.elems byId), + Right x <- [decode bs] + ] + +-- | Record who spends the outputs of cached transactions: these +-- transactions spend them, or no longer do if they were deleted. +updateSpenders :: Cache -> [TxData] -> IO () +updateSpenders c tds = + unless (null quads) $ + void (run c (R.eval spendsScript [] args :: Redis (Either Reply Integer))) + where + args = c.prefix : num (length quads) : concat quads + quads = + [ [ encode i.outpoint.hash, + encode i.outpoint.index, + if td.deleted then "" else encode (Spender (txHash td.tx) n), + encode (txHash td.tx) + ] + | td <- tds, + (n, i) <- zip [0 ..] td.tx.inputs + ] + +------------------------------------------------------------------------------- +-- Lua scripts +------------------------------------------------------------------------------- + +-- The scripts that Redis runs are in files of their own under +-- @src\/Haskoin\/Store\/Cache\/lua@, where they can be read, linted and run +-- with @redis-cli --eval@ on their own, and are embedded here when the module +-- is compiled. Embedding them, rather than reading them when the server +-- starts, keeps the library free of data files that a program using it would +-- have to install and find. Their comments are sent with every call, so keep +-- them short; the full description of each is the Haddock of its binding. + +-- | Delete an xpub. Arguments: prefix, id. Returns 1 if it was cached. +deleteScript :: ByteString +deleteScript = $(makeRelativeToProject "src/Haskoin/Store/Cache/lua/delete.lua" >>= embedFile) + +-- | Evict the least recently used xpubs past a number. Arguments: prefix, +-- maximum. Returns how many were evicted. +evictScript :: ByteString +evictScript = $(makeRelativeToProject "src/Haskoin/Store/Cache/lua/evict.lua" >>= embedFile) + +-- | A page of a sorted set of a cached xpub; see 'page'. Arguments: the +-- keys of the meta hash, of the sorted set and of the sorted set of +-- transactions, the key of the set of recent use, the time to mark the xpub +-- used with (empty for not now), the id of the xpub, the offset and the limit +-- (0 for no limit), and how the page starts: @top@; @score@ and a score; +-- @at@, a score, a number of bytes and the bytes of the start; or @tx@, a +-- transaction hash, a number of bytes and the bytes of the start. Returns +-- @{\"none\"}@ if the xpub is not cached, @{\"nostart\"}@ if the +-- transaction of @tx@ is not one of the xpub, or @{\"ok\"}@ followed by +-- each member and its score. +-- +-- Bytes are compared one by one: Lua compares strings by the collation of +-- the locale of the server, which need not be the order of their bytes that +-- Redis and the database sort members by. +pageScript :: ByteString +pageScript = $(makeRelativeToProject "src/Haskoin/Store/Cache/lua/page.lua" >>= embedFile) + +-- | Apply the differences of an entry of an xpub, unless the stored one is +-- stamped with a higher block, or is not the generation they were computed +-- from. Arguments: prefix, id, height, time of use, serialized xpub, +-- balances, generation (empty for none); then, each preceded by its number, +-- the addresses to add, the addresses to remove, the transactions to add or +-- move with their scores, the transactions to remove, the unspent outputs to +-- add with their scores, the unspent outputs to remove, the bodies to write +-- with their hashes, and the spenders with their transaction and output +-- index. Returns @{\"stale\"}@ if the stored entry has a higher block, +-- @{\"changed\"}@ if its generation is not the one given, +-- @{\"missing\", ...}@ with the hashes of added transactions that have no +-- body in Redis nor in the arguments, or @{\"ok\"}@. Nothing is written +-- unless it returns @{\"ok\"}@. +-- +-- A transaction removed from the entry loses this xpub from its set of +-- xpubs, and its body goes when no cached xpub has it any more. +commitScript :: ByteString +commitScript = $(makeRelativeToProject "src/Haskoin/Store/Cache/lua/commit.lua" >>= embedFile) + +-- | Rewrite bodies that Redis has, with their spenders; see 'rewriteBodies'. +-- Arguments: prefix, then as at the end of 'commitScript': the number of +-- bodies, the hash and body of each, the number of spenders, and the +-- transaction, output index and spender of each. Returns the hashes of the +-- bodies that Redis does not have, which it does not write. +bodiesScript :: ByteString +bodiesScript = $(makeRelativeToProject "src/Haskoin/Store/Cache/lua/bodies.lua" >>= embedFile) + +-- | Record or forget spenders of outputs of cached transactions. Arguments: +-- prefix, number of entries, then for each: hash of the transaction that +-- created the output, output index, spender (empty to forget) and hash of +-- the spending transaction. Only transactions whose body is cached are +-- touched, and a spender is only forgotten if it is still the one given. +spendsScript :: ByteString +spendsScript = $(makeRelativeToProject "src/Haskoin/Store/Cache/lua/spends.lua" >>= embedFile) + +-- | Release a lock if it still holds the given token. Keys: lock. Arguments: +-- token. +unlockScript :: ByteString +unlockScript = $(makeRelativeToProject "src/Haskoin/Store/Cache/lua/unlock.lua" >>= embedFile) diff --git a/src/Haskoin/Store/Cache/Protocol.hs b/src/Haskoin/Store/Cache/Protocol.hs new file mode 100644 --- /dev/null +++ b/src/Haskoin/Store/Cache/Protocol.hs @@ -0,0 +1,122 @@ +-- | +-- Module : Haskoin.Store.Cache.Protocol +-- Copyright : (c) Haskoin Developers +-- License : MIT +-- Maintainer : jprupp@protonmail.ch +-- Stability : experimental +-- Portability : POSIX +-- +-- The rules that stores sharing one Redis follow to apply each change of a +-- cached xpub once, as pure decisions. "Haskoin.Store.Cache" carries them +-- out against Redis. +-- +-- Each change (a block, or a transaction entering or leaving the mempool, +-- for one xpub) has a claim in Redis that goes through these states: +-- +-- @ +-- claim reload succeeds +-- absent ─────────► busy ─────────────────► done (for an hour) +-- ▲ │ +-- └─────────────────┘ Redis knew more: release +-- @ +-- +-- A store that finds the claim busy tries again later; one that finds it +-- done skips the change. While it holds the claim, it reloads the xpub from +-- its database, unless the entry in Redis knows more than the database +-- ('mayReplace'), in which case it releases the claim and writes nothing. +-- +-- = Why these rules +-- +-- * __A change is applied once.__ The first store to see a change claims it; +-- stores that see it later, because they are behind, find it done. A set of +-- stores catching up does no work for changes already applied. +-- * __Stores never undo each other.__ An entry is stamped with the best block +-- of the store that wrote it, and no store replaces an entry stamped with a +-- higher block, or one with a transaction it has never seen. Without this +-- rule, a store that is behind would replace a newer entry with an older +-- one, and the next store would put the newer one back. +-- * __An entry is complete.__ The entry is written with every transaction +-- body that it needs, in one script, so a store that is behind can serve +-- it without its database. +module Haskoin.Store.Cache.Protocol + ( -- * Claims + Claim (..), + OnClaim (..), + afterClaim, + + -- * Reloads + Reload (..), + OnReload (..), + afterReload, + mayReplace, + ) +where + +import Haskoin (BlockHeight) + +-- | The state of the claim of a change, as a store that tries to claim it +-- finds it. +data Claim + = -- | it was absent: this store holds it now + Claimed + | -- | another store applied the change + Done + | -- | another store holds the claim + Busy + deriving stock (Eq, Show, Enum, Bounded) + +-- | What to do after trying to claim a change. +data OnClaim + = -- | reload the xpub, holding the claim + ReloadNow + | -- | nothing: the change was applied + Skip + | -- | try to claim it again later, in case its holder gives it up + ClaimLater + deriving stock (Eq, Show) + +-- | What to do after trying to claim a change. +afterClaim :: Claim -> OnClaim +afterClaim = \case + Claimed -> ReloadNow + Done -> Skip + Busy -> ClaimLater + +-- | What became of a reload. +data Reload + = -- | the entry was replaced + Reloaded + | -- | Redis knows more about the xpub than this store: its entry is stamped + -- with a higher block, or has a transaction this store has never seen. It + -- is left for a store that knows more. + Behind + | -- | another store holds the lock of the xpub + Locked + deriving stock (Eq, Show, Enum, Bounded) + +-- | What to do with the claims of the changes that a reload was for. +data OnReload + = -- | mark them done + Finish + | -- | give them up, for a store that knows more + Release + | -- | keep holding them, and reload again later + Hold + deriving stock (Eq, Show) + +-- | What to do with the claims of the changes that a reload was for. +afterReload :: Reload -> OnReload +afterReload = \case + Reloaded -> Finish + Behind -> Release + Locked -> Hold + +-- | Whether a store may replace the entry of an xpub: given the block height +-- that the entry is stamped with, if there is an entry, the height of the +-- best block of the store, and whether the entry has a transaction that the +-- store has never seen. An entry of the same height may be replaced, as it +-- can differ only in the mempool. The commit script checks the height again, +-- atomically, as another store may write between the check and the commit. +mayReplace :: Maybe Integer -> BlockHeight -> Bool -> Bool +mayReplace stamp height unknownTxs = + maybe True (<= toInteger height) stamp && not unknownTxs diff --git a/src/Haskoin/Store/Cache/lua/bodies.lua b/src/Haskoin/Store/Cache/lua/bodies.lua new file mode 100644 --- /dev/null +++ b/src/Haskoin/Store/Cache/lua/bodies.lua @@ -0,0 +1,25 @@ +-- Rewrite bodies that Redis has, ahead of a commit: bodiesScript in Haskoin.Store.Cache. +local p = ARGV[1] +local nb = tonumber(ARGV[2]) +local bi = 3 +local si = bi + 2 * nb + 1 +local ns = tonumber(ARGV[si - 1]) +local written = {} +local absent = {} +for j = 0, nb - 1 do + local t = ARGV[bi + 2 * j] + if redis.call('EXISTS', p .. 'tx:' .. t) == 1 then + redis.call('SET', p .. 'tx:' .. t, ARGV[bi + 2 * j + 1]) + redis.call('DEL', p .. 'sp:' .. t) + written[t] = true + else + table.insert(absent, t) + end +end +for j = 0, ns - 1 do + local k = si + 3 * j + if written[ARGV[k]] then + redis.call('HSET', p .. 'sp:' .. ARGV[k], ARGV[k + 1], ARGV[k + 2]) + end +end +return absent diff --git a/src/Haskoin/Store/Cache/lua/commit.lua b/src/Haskoin/Store/Cache/lua/commit.lua new file mode 100644 --- /dev/null +++ b/src/Haskoin/Store/Cache/lua/commit.lua @@ -0,0 +1,92 @@ +-- Apply the differences of an entry of an xpub: commitScript in Haskoin.Store.Cache. +local p = ARGV[1] +local id = ARGV[2] +local h = tonumber(ARGV[3]) +local xk = p .. 'x:' .. id .. ':' +local meta = xk .. 'meta' +local oh = redis.call('HGET', meta, 'height') +if oh and h < tonumber(oh) then return {'stale'} end +if (redis.call('HGET', meta, 'gen') or '') ~= ARGV[7] then return {'changed'} end +local full = ARGV[8] +local i = 9 +local function list(width) + local n = tonumber(ARGV[i]) + local s = i + 1 + i = s + width * n + return s, n +end +local aa, naa = list(1) +local ad, nad = list(1) +local ta, nta = list(2) +local td, ntd = list(1) +local ua, nua = list(3) +local ud, nud = list(2) +local bi, nb = list(2) +local si, ns = list(3) +local given = {} +for j = 0, nb - 1 do given[ARGV[bi + 2 * j]] = true end +local missing = {'missing'} +for j = 0, nta - 1 do + local t = ARGV[ta + 2 * j] + if not given[t] and redis.call('EXISTS', p .. 'tx:' .. t) == 0 then + table.insert(missing, t) + end +end +if #missing > 1 then return missing end +for j = 0, nad - 1 do + local a = ARGV[ad + j] + redis.call('SREM', p .. 'a:' .. a, id) + redis.call('SREM', xk .. 'addrs', a) +end +for j = 0, naa - 1 do + local a = ARGV[aa + j] + redis.call('SADD', p .. 'a:' .. a, id) + redis.call('SADD', xk .. 'addrs', a) +end +for j = 0, ntd - 1 do + local t = ARGV[td + j] + local rk = p .. 'txref:' .. t + redis.call('ZREM', xk .. 'txs', t) + redis.call('SREM', rk, id) + if redis.call('SCARD', rk) == 0 then + redis.call('DEL', rk, p .. 'tx:' .. t, p .. 'sp:' .. t) + end +end +for j = 0, nta - 1 do + local t = ARGV[ta + 2 * j] + redis.call('ZADD', xk .. 'txs', ARGV[ta + 2 * j + 1], t) + redis.call('SADD', p .. 'txref:' .. t, id) +end +-- unspent outputs by outpoint: uop maps each to its member, which changes +-- with the block of the output, so that one can go by its outpoint alone +local uop = xk .. 'uop' +for j = 0, nud - 1 do + local op, m = ARGV[ud + 2 * j], ARGV[ud + 2 * j + 1] + if m == '' then m = redis.call('HGET', uop, op) end + if m then redis.call('ZREM', xk .. 'utxo', m) end + redis.call('HDEL', uop, op) +end +for j = 0, nua - 1 do + local op, m = ARGV[ua + 3 * j], ARGV[ua + 3 * j + 1] + local old = redis.call('HGET', uop, op) + if old and old ~= m then redis.call('ZREM', xk .. 'utxo', old) end + redis.call('ZADD', xk .. 'utxo', ARGV[ua + 3 * j + 2], m) + redis.call('HSET', uop, op, m) +end +for j = 0, nb - 1 do + local t = ARGV[bi + 2 * j] + redis.call('SET', p .. 'tx:' .. t, ARGV[bi + 2 * j + 1]) + redis.call('DEL', p .. 'sp:' .. t) +end +for j = 0, ns - 1 do + local k = si + 3 * j + if given[ARGV[k]] then + redis.call('HSET', p .. 'sp:' .. ARGV[k], ARGV[k + 1], ARGV[k + 2]) + end +end +redis.call('SET', xk .. 'bal', ARGV[6]) +redis.call('HSET', meta, 'spec', ARGV[5], 'height', ARGV[3], 'ver', '3') +if full ~= '' then redis.call('HSET', meta, 'full', full) end +redis.call('HINCRBY', meta, 'gen', 1) +redis.call('ZADD', p .. 'lru', ARGV[4], id) +return {'ok'} diff --git a/src/Haskoin/Store/Cache/lua/delete.lua b/src/Haskoin/Store/Cache/lua/delete.lua new file mode 100644 --- /dev/null +++ b/src/Haskoin/Store/Cache/lua/delete.lua @@ -0,0 +1,18 @@ +-- Delete an xpub: deleteScript in Haskoin.Store.Cache. evict.lua removes +-- xpubs the same way. +local p = ARGV[1] +local id = ARGV[2] +local xk = p .. 'x:' .. id .. ':' +for _, a in ipairs(redis.call('SMEMBERS', xk .. 'addrs')) do + redis.call('SREM', p .. 'a:' .. a, id) +end +for _, t in ipairs(redis.call('ZRANGE', xk .. 'txs', 0, -1)) do + local rk = p .. 'txref:' .. t + redis.call('SREM', rk, id) + if redis.call('SCARD', rk) == 0 then + redis.call('DEL', rk, p .. 'tx:' .. t, p .. 'sp:' .. t) + end +end +local existed = redis.call('DEL', xk .. 'meta', xk .. 'bal', xk .. 'txs', xk .. 'utxo', xk .. 'addrs', xk .. 'uop') +redis.call('ZREM', p .. 'lru', id) +if existed > 0 then return 1 else return 0 end diff --git a/src/Haskoin/Store/Cache/lua/evict.lua b/src/Haskoin/Store/Cache/lua/evict.lua new file mode 100644 --- /dev/null +++ b/src/Haskoin/Store/Cache/lua/evict.lua @@ -0,0 +1,23 @@ +-- Evict the least recently used xpubs past a number: evictScript in +-- Haskoin.Store.Cache. Each xpub goes as delete.lua removes one. +local p = ARGV[1] +local max = tonumber(ARGV[2]) +local n = 0 +while redis.call('ZCARD', p .. 'lru') > max do + local id = redis.call('ZRANGE', p .. 'lru', 0, 0)[1] + local xk = p .. 'x:' .. id .. ':' + for _, a in ipairs(redis.call('SMEMBERS', xk .. 'addrs')) do + redis.call('SREM', p .. 'a:' .. a, id) + end + for _, t in ipairs(redis.call('ZRANGE', xk .. 'txs', 0, -1)) do + local rk = p .. 'txref:' .. t + redis.call('SREM', rk, id) + if redis.call('SCARD', rk) == 0 then + redis.call('DEL', rk, p .. 'tx:' .. t, p .. 'sp:' .. t) + end + end + redis.call('DEL', xk .. 'meta', xk .. 'bal', xk .. 'txs', xk .. 'utxo', xk .. 'addrs', xk .. 'uop') + redis.call('ZREM', p .. 'lru', id) + n = n + 1 +end +return n diff --git a/src/Haskoin/Store/Cache/lua/page.lua b/src/Haskoin/Store/Cache/lua/page.lua new file mode 100644 --- /dev/null +++ b/src/Haskoin/Store/Cache/lua/page.lua @@ -0,0 +1,39 @@ +-- A page of a sorted set of a cached xpub: pageScript in Haskoin.Store.Cache. +local set, txs = ARGV[2], ARGV[3] +if redis.call('EXISTS', ARGV[1]) == 0 then return {'none'} end +if ARGV[5] ~= '' then redis.call('ZADD', ARGV[4], ARGV[5], ARGV[6]) end +local off = tonumber(ARGV[7]) +local lim = tonumber(ARGV[8]) +local mode = ARGV[9] +local function lt(a, b) + for k = 1, math.min(#a, #b) do + local x, y = string.byte(a, k), string.byte(b, k) + if x ~= y then return x < y end + end + return #a < #b +end +local function out(r) + local o = {'ok'} + for _, v in ipairs(r) do table.insert(o, v) end + return o +end +if mode == 'top' then + local stop = -1 + if lim > 0 then stop = off + lim - 1 end + return out(redis.call('ZRANGE', set, off, stop, 'WITHSCORES')) +end +local score = ARGV[10] +local skip = 0 +if mode == 'tx' then + score = redis.call('ZSCORE', txs, ARGV[10]) + if not score then return {'nostart'} end +end +if mode ~= 'score' then + local cut, bytes = tonumber(ARGV[11]), ARGV[12] + for _, m in ipairs(redis.call('ZRANGEBYSCORE', set, score, score)) do + if lt(string.sub(m, cut + 1), bytes) then skip = skip + 1 end + end +end +local count = -1 +if lim > 0 then count = lim end +return out(redis.call('ZRANGEBYSCORE', set, score, '+inf', 'WITHSCORES', 'LIMIT', off + skip, count)) diff --git a/src/Haskoin/Store/Cache/lua/spends.lua b/src/Haskoin/Store/Cache/lua/spends.lua new file mode 100644 --- /dev/null +++ b/src/Haskoin/Store/Cache/lua/spends.lua @@ -0,0 +1,20 @@ +-- Record or forget spenders of outputs of cached transactions: spendsScript in Haskoin.Store.Cache. +local p = ARGV[1] +local n = tonumber(ARGV[2]) +local i = 3 +for j = 1, n do + local t = ARGV[i] + if redis.call('EXISTS', p .. 'tx:' .. t) == 1 then + local sk = p .. 'sp:' .. t + if ARGV[i + 2] ~= '' then + redis.call('HSET', sk, ARGV[i + 1], ARGV[i + 2]) + else + local cur = redis.call('HGET', sk, ARGV[i + 1]) + if cur and string.sub(cur, 1, 32) == ARGV[i + 3] then + redis.call('HDEL', sk, ARGV[i + 1]) + end + end + end + i = i + 4 +end +return 1 diff --git a/src/Haskoin/Store/Cache/lua/unlock.lua b/src/Haskoin/Store/Cache/lua/unlock.lua new file mode 100644 --- /dev/null +++ b/src/Haskoin/Store/Cache/lua/unlock.lua @@ -0,0 +1,5 @@ +-- Release a lock if it still holds the given token: unlockScript in Haskoin.Store.Cache. +if redis.call('GET', KEYS[1]) == ARGV[1] then + return redis.call('DEL', KEYS[1]) +end +return 0 diff --git a/src/Haskoin/Store/Common.hs b/src/Haskoin/Store/Common.hs --- a/src/Haskoin/Store/Common.hs +++ b/src/Haskoin/Store/Common.hs @@ -1,12 +1,4 @@ -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ImportQualifiedPost #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE NoFieldSelectors #-} -- | -- Module : Haskoin.Store.Common @@ -18,22 +10,15 @@ -- -- Interfaces shared by every part of the store. -- --- 'StoreReadBase' and 'StoreReadExtra' abstract over anything that can answer --- queries about blocks, transactions, addresses and extended public keys: the --- RocksDB database ("Haskoin.Store.Database.Reader"), the in-memory write --- buffer used while importing ("Haskoin.Store.Database.Writer"), and the Redis --- cache ("Haskoin.Store.Cache"). 'StoreWrite' is implemented by the writer. +-- 'StoreRead' is the queries that the web server asks about blocks, +-- transactions, addresses and extended public keys, as a record of functions +-- in 'IO': "Haskoin.Store.Database.Query" gives them for the RocksDB +-- database, and the web server puts the Redis cache in front of some. -- -- This module also has helpers for pagination ('Limits'), for deriving --- addresses from extended public keys, and for merging sorted streams. --- = Why the store is a set of type classes --- --- The same questions are asked in three places: by the web server against the --- database, by the import logic against a buffer of uncommitted changes, and by --- the cache, which answers some questions itself and passes others on. Writing --- the queries once against a class, and providing instances for each place, keeps --- those three in agreement and lets the cache sit transparently in front of the --- database. +-- addresses from extended public keys ('scanXPubBals'), for the order of +-- transactions and outputs ('txRefKey', 'unspentKey'), and for merging sorted +-- streams. -- -- = Why pages start at a transaction -- @@ -44,12 +29,11 @@ module Haskoin.Store.Common ( Limits (..), Start (..), - StoreReadBase (..), - StoreReadExtra (..), - StoreWrite (..), + StoreRead (..), StoreEvent (..), getActiveBlock, getActiveTxData, + notDeleted, getDefaultBalance, getTransaction, getTransactions, @@ -60,6 +44,9 @@ xPubSummary, deriveAddresses, deriveFunction, + scanXPubBals, + txRefKey, + unspentKey, deOffset, applyLimits, applyLimitsC, @@ -86,18 +73,18 @@ ($$++), ) import Control.Monad.Trans (lift) -import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) -import Control.Monad.Trans.Reader (runReaderT) import Data.ByteString (ByteString) import Data.Default (Default (..)) +import Data.Functor ((<&>)) import Data.Graph qualified as G import Data.HashMap.Strict qualified as M import Data.HashSet qualified as H import Data.Hashable (Hashable) -import Data.Map.Strict qualified as Map import Data.List (sortOn) -import Data.Maybe (catMaybes, mapMaybe) +import Data.Map.Strict qualified as Map +import Data.Maybe (catMaybes, fromMaybe, mapMaybe) import Data.Ord (Down (..)) +import Data.Serialize (encode) import Data.Time.Clock.System ( getSystemTime, systemNanoseconds, @@ -105,10 +92,11 @@ ) import Data.Word (Word32, Word64) import Haskoin -import Haskoin.Node (Chain, Peer) +import Haskoin.Node (Chain, Peer, chainRunHeaders) import Haskoin.Store.Data ( Balance (..), BlockData (..), + BlockRef (..), DeriveType (..), Spender, Transaction (..), @@ -124,7 +112,6 @@ toTransaction, zeroBalance, ) -import UnliftIO (MonadIO, liftIO) -- | Function to derive the address at an index of an extended public key. type DeriveAddr = XPubKey -> KeyIndex -> Address @@ -141,8 +128,9 @@ -- entered the mempool, and for a confirmed one, at its position in the -- chain AtTx !TxHash - | -- | at this block height, including every transaction in the mempool if it - -- is above the best block + | -- | at the last transaction confirmed at or below this block height. + -- Nothing of the mempool is in the page, not even when the height is + -- above the best block AtBlock !BlockHeight deriving (Eq, Show) @@ -165,131 +153,117 @@ instance Default Limits where def = defaultLimits --- | Basic queries that every store answers. -class (Monad m) => StoreReadBase m where - -- | Network the store indexes. - getNetwork :: m Network - -- | Context for secp256k1 operations, needed to parse and derive keys. - getCtx :: m Ctx - -- | Hash of the best block imported, or 'Nothing' if none was imported yet. - getBestBlock :: m (Maybe BlockHash) - -- | Hashes of all blocks imported at a height, including those on side - -- chains. - getBlocksAtHeight :: BlockHeight -> m [BlockHash] - -- | Data of a block imported in the past, whether still in the main chain - -- or not. Check 'Haskoin.Store.Data.main' to know. - getBlock :: BlockHash -> m (Maybe BlockData) - -- | Data of a transaction, including deleted ones. Check - -- 'Haskoin.Store.Data.deleted' to know. - getTxData :: TxHash -> m (Maybe TxData) - - -- | Data of many transactions, in the order of their hashes. Stores that - -- can read many keys at once read them together. - getManyTxData :: [TxHash] -> m [Maybe TxData] - getManyTxData = mapM getTxData - - -- | Transaction input that spends an output, if it is spent. - getSpender :: OutPoint -> m (Maybe Spender) - -- | Balance of an address, or 'Nothing' if it was never used. - getBalance :: Address -> m (Maybe Balance) - -- | Unspent output, or 'Nothing' if it does not exist or is spent. - getUnspent :: OutPoint -> m (Maybe Unspent) - -- | Whole mempool, newest first. - getMempool :: m [(UnixTime, TxHash)] - - -- | Page of the mempool, newest first, from the offset and limit of the - -- 'Limits'; its start is ignored. Stores that index the mempool by time - -- read only the entries of the page instead of the whole mempool. - getMempoolPage :: Limits -> m [(UnixTime, TxHash)] - getMempoolPage l = applyLimits l <$> getMempool - --- | Queries about addresses and extended public keys, which need indices or --- configuration beyond the basic store. -class (StoreReadBase m) => StoreReadExtra m where - -- | Transactions involving any of the addresses, newest first, without - -- duplicates. - getAddressesTxs :: [Address] -> Limits -> m [TxRef] - -- | Unspent outputs of any of the addresses, newest first. - getAddressesUnspents :: [Address] -> Limits -> m [Unspent] - -- | Number of unused addresses to look ahead when deriving the addresses of - -- an extended public key that has no transactions yet. - getInitialGap :: m Word32 - -- | Number of consecutive unused addresses after which derivation of an - -- extended public key stops. - getMaxGap :: m Word32 - -- | Transactions whose hash, read as a number, matches the short identifier - -- used by the Blockchain.info compatibility API. There may be more than one. - getNumTxData :: Word64 -> m [TxData] - -- | Balances of the addresses, in the same order. Addresses never used get - -- a zero balance. - getBalances :: [Address] -> m [Balance] - -- | Transactions involving an address, newest first. - getAddressTxs :: Address -> Limits -> m [TxRef] - -- | Unspent outputs of an address, newest first. - getAddressUnspents :: Address -> Limits -> m [Unspent] - -- | Balances of the used addresses of an extended public key, with their - -- derivation paths. - xPubBals :: XPubSpec -> m [XPubBal] - -- | Unspent outputs of an extended public key, newest first. The second - -- argument is the result of 'xPubBals' for the same key. - xPubUnspents :: XPubSpec -> [XPubBal] -> Limits -> m [XPubUnspent] - -- | Transactions of an extended public key, newest first. The second - -- argument is the result of 'xPubBals' for the same key. - xPubTxs :: XPubSpec -> [XPubBal] -> Limits -> m [TxRef] - -- | Number of transactions of an extended public key. The second argument - -- is the result of 'xPubBals' for the same key. - xPubTxCount :: XPubSpec -> [XPubBal] -> m Word32 - --- | Changes to the index. Implemented by the writer, which buffers them in --- memory and commits them to the database in one batch. -class StoreWrite m where - -- | Set the best block. - setBest :: BlockHash -> m () - -- | Add or replace the data of a block. - insertBlock :: BlockData -> m () - -- | Set the hashes of the blocks at a height. - setBlocksAtHeight :: [BlockHash] -> BlockHeight -> m () - -- | Add or replace the data of a transaction. - insertTx :: TxData -> m () - -- | Add a transaction to the index of an address. - insertAddrTx :: Address -> TxRef -> m () - -- | Remove a transaction from the index of an address. - deleteAddrTx :: Address -> TxRef -> m () - -- | Add an unspent output to the index of an address. - insertAddrUnspent :: Address -> Unspent -> m () - -- | Remove an unspent output from the index of an address. - deleteAddrUnspent :: Address -> Unspent -> m () - -- | Add a transaction to the mempool, with the time it arrived. - addToMempool :: TxHash -> UnixTime -> m () - -- | Remove a transaction from the mempool. - deleteFromMempool :: TxHash -> m () - -- | Set the balance of an address. - setBalance :: Balance -> m () - -- | Add an unspent output. - insertUnspent :: Unspent -> m () - -- | Remove an unspent output. - deleteUnspent :: OutPoint -> m () +-- | The queries that the web server answers with, as plain functions in +-- 'IO'. "Haskoin.Store.Database.Query" gives them for the database +-- ('Haskoin.Store.Database.Query.databaseRead'); the web server puts the +-- Redis cache in front of some of them. +-- +-- A record of functions rather than a class: a class needs a monad to pick +-- its instance, and the store has no monads of its own to pick it with, only +-- 'IO'. The record makes the source of every answer an ordinary value that +-- can be passed around and replaced, as @nocache=true@ does. +data StoreRead = StoreRead + { -- | network the store indexes + net :: !Network, + -- | context for secp256k1 operations, needed to parse and derive keys + ctx :: !Ctx, + -- | hash of the best block imported, or 'Nothing' if none yet + getBestBlock :: IO (Maybe BlockHash), + -- | hashes of all blocks imported at a height, side chains included + getBlocksAtHeight :: BlockHeight -> IO [BlockHash], + -- | data of a block imported in the past, whether still in the main + -- chain or not; check 'Haskoin.Store.Data.main' to know + getBlock :: BlockHash -> IO (Maybe BlockData), + -- | data of a transaction that is confirmed or in the mempool. One + -- that was deleted is not returned, here or by the two queries below; + -- see 'notDeleted' + getTxData :: TxHash -> IO (Maybe TxData), + -- | data of many transactions, in the order of their hashes, read + -- together + getManyTxData :: [TxHash] -> IO [Maybe TxData], + -- | transaction input that spends an output, if it is spent + getSpender :: OutPoint -> IO (Maybe Spender), + -- | balance of an address, or 'Nothing' if it was never used + getBalance :: Address -> IO (Maybe Balance), + -- | unspent output, or 'Nothing' if it does not exist or is spent + getUnspent :: OutPoint -> IO (Maybe Unspent), + -- | whole mempool, newest first + getMempool :: IO [(UnixTime, TxHash)], + -- | page of the mempool, newest first, from the offset and limit of the + -- 'Limits'; its start is ignored + getMempoolPage :: Limits -> IO [(UnixTime, TxHash)], + -- | transactions involving any of the addresses, newest first, without + -- duplicates + getAddressesTxs :: [Address] -> Limits -> IO [TxRef], + -- | unspent outputs of any of the addresses, newest first + getAddressesUnspents :: [Address] -> Limits -> IO [Unspent], + -- | unused addresses to look at for an extended public key with no + -- transactions yet + initialGap :: !Word32, + -- | consecutive unused addresses after which derivation of an extended + -- public key stops + maxGap :: !Word32, + -- | transactions whose hash, read as a number, matches the short + -- identifier of the Blockchain.info compatible API; there may be more + -- than one + getNumTxData :: Word64 -> IO [TxData], + -- | balances of the addresses, in the same order; addresses never used + -- get a zero balance + getBalances :: [Address] -> IO [Balance], + -- | transactions involving an address, newest first + getAddressTxs :: Address -> Limits -> IO [TxRef], + -- | unspent outputs of an address, newest first + getAddressUnspents :: Address -> Limits -> IO [Unspent], + -- | balances of the used addresses of an extended public key, with + -- their derivation paths + xPubBals :: XPubSpec -> IO [XPubBal], + -- | unspent outputs of an extended public key, newest first, given its + -- balances from 'xPubBals' + xPubUnspents :: XPubSpec -> [XPubBal] -> Limits -> IO [XPubUnspent], + -- | transactions of an extended public key, newest first, given its + -- balances from 'xPubBals' + xPubTxs :: XPubSpec -> [XPubBal] -> Limits -> IO [TxRef], + -- | number of transactions of an extended public key, given its + -- balances from 'xPubBals' + xPubTxCount :: XPubSpec -> [XPubBal] -> IO Word32, + -- | number of distinct transactions of a set of addresses, counted + -- without reading them + getAddressesTxCount :: [Address] -> IO Word32 + } -- | Data of a block, or 'Nothing' if it is unknown or not in the main chain. -getActiveBlock :: (StoreReadExtra m) => BlockHash -> m (Maybe BlockData) -getActiveBlock bh = - getBlock bh >>= \case - Just b | b.main -> return (Just b) - _ -> return Nothing +getActiveBlock :: StoreRead -> BlockHash -> IO (Maybe BlockData) +getActiveBlock r bh = + r.getBlock bh <&> \case + Just b | b.main -> Just b + _ -> Nothing +-- | Leave out a transaction that was deleted: replaced, dropped from the +-- mempool, or the coinbase of a block that left the main chain. +-- +-- The store used to answer with such transactions, marked as deleted, so +-- that a wallet could say what became of a payment. Some clients do not +-- look at the mark, and took a payment that will never happen for one that +-- is pending. So every 'StoreRead' leaves them out, and to the API a +-- deleted transaction is one that the store does not know. Since database +-- version 22 nothing is kept of them at all; this is for the bodies that +-- version 20 left in a database that was migrated. +notDeleted :: Maybe TxData -> Maybe TxData +notDeleted (Just td) | td.deleted = Nothing +notDeleted found = found + -- | Data of a transaction, or 'Nothing' if it is unknown or was deleted. -getActiveTxData :: (StoreReadBase m) => TxHash -> m (Maybe TxData) -getActiveTxData th = - getTxData th >>= \case - Just td | not td.deleted -> return (Just td) - _ -> return Nothing +-- The same as the query of a 'StoreRead' now that it leaves deleted +-- transactions out. +getActiveTxData :: StoreRead -> TxHash -> IO (Maybe TxData) +getActiveTxData r th = + r.getTxData th <&> \case + Just td | not td.deleted -> Just td + _ -> Nothing -- | Balance of an address, or a zero balance if the address was never used. -getDefaultBalance :: (StoreReadBase m) => Address -> m Balance -getDefaultBalance a = - getBalance a >>= \case - Nothing -> return $ zeroBalance a - Just b -> return b +getDefaultBalance :: StoreRead -> Address -> IO Balance +getDefaultBalance r a = fromMaybe (zeroBalance a) <$> r.getBalance a -- | Infinite list of the addresses of an extended public key, with their -- indices, from the given index on. @@ -304,6 +278,76 @@ deriveFunction ctx DeriveP2SH i = fst . deriveCompatWitnessAddr ctx i deriveFunction ctx DeriveP2WPKH i = fst . deriveWitnessAddr ctx i +-- | Balances of the addresses of an extended public key, derived up to the +-- gap: every address of each chain up to the last used one, followed by +-- exactly @gap@ unused ones. Arguments, in order: a function to read the +-- balances of addresses, the initial gap, the gap, the external chain and +-- the change chain (both infinite lists of indices and addresses). +-- +-- The first @initial gap@ external addresses are read first. If none is used, +-- the key is taken as unused, those balances are returned and nothing more is +-- read. Otherwise each chain is read until the last @gap@ addresses are +-- unused, counting the unused addresses at the end of the initial block too. +-- The initial block is always returned whole, even when it reaches past the +-- gap after its last used address (an initial gap larger than the gap): it +-- was read, so a payment to any of its addresses is seen, and the cache must +-- keep those addresses to see it too. +-- +-- = Why the gap is exact +-- +-- The gap is the number of unused addresses a wallet may hand out in a row. +-- Wallets follow BIP 44 and stop looking for payments after that many, so a +-- store that looked further would show payments the wallet cannot see, and a +-- store that sometimes looked further and sometimes not would make the answer +-- depend on how the reads happened to be batched. Earlier versions read 32 +-- addresses at a time and checked the gap only between batches, so they +-- looked between 33 and 64 addresses past the last used one, and started +-- counting again at the end of the initial block. The Redis cache keeps +-- exactly @gap@ unused addresses, so cached and uncached answers differed +-- whenever a payment fell in the extra range. +-- +-- Reads are still batched: each read asks for as many addresses as are still +-- needed to complete the gap if all of them turn out unused, so no address +-- past the gap is ever read, and a run of unused addresses costs one read. +scanXPubBals :: + (Monad m) => + ([Address] -> m [Balance]) -> + Word32 -> + Word32 -> + [(Word32, Address)] -> + [(Word32, Address)] -> + m [XPubBal] +scanXPubBals getBals igap gap ext chg = do + let (first, rest) = splitAt (fromIntegral igap) ext + ext1 <- readChain 0 first + if all nullxb ext1 + then return ext1 + else do + ext2 <- go (length ext1) 0 (reverse ext1) rest + chg' <- go 0 1 [] chg + return (ext2 <> chg') + where + g = fromIntegral gap :: Int + nullxb b = nullBalance b.balance + readChain m as = do + bs <- getBals (map snd as) + return $ zipWith (\(n, _) b -> XPubBal {path = [m, n], balance = b}) as bs + -- acc holds the balances read so far, newest first; keep is the number + -- of addresses at the start of the chain to return in any case + trailing = length . takeWhile nullxb + go keep m acc as + | trailing acc >= g = return (trim keep acc) + | otherwise = + case splitAt (g - trailing acc) as of + ([], _) -> return (trim keep acc) + (now, later) -> do + bs <- readChain m now + go keep m (reverse bs <> acc) later + trim keep acc = + let (ns, ys) = span nullxb acc + gapped = reverse ys <> take g (reverse ns) + in if length gapped >= keep then gapped else take keep (reverse acc) + -- | Summary of the balances of an extended public key, from the balances of its -- addresses. The received total only counts external addresses, and the -- indices are those of the last used external and change addresses. @@ -326,73 +370,52 @@ rx = sum [b.balance.received | b <- xt] -- | Transaction with its metadata, or 'Nothing' if it is unknown. -getTransaction :: - (StoreReadBase m) => TxHash -> m (Maybe Transaction) -getTransaction h = do - net <- getNetwork - ctx <- getCtx - fmap (toTransaction net ctx) <$> getTxData h +getTransaction :: StoreRead -> TxHash -> IO (Maybe Transaction) +getTransaction r h = fmap (toTransaction r.net r.ctx) <$> r.getTxData h -- | Many transactions, in the order of their hashes, read together. -getTransactions :: - (StoreReadBase m) => [TxHash] -> m [Maybe Transaction] -getTransactions hs = do - net <- getNetwork - ctx <- getCtx - map (fmap (toTransaction net ctx)) <$> getManyTxData hs +getTransactions :: StoreRead -> [TxHash] -> IO [Maybe Transaction] +getTransactions r hs = map (fmap (toTransaction r.net r.ctx)) <$> r.getManyTxData hs -- | Transactions that match a short numeric identifier; see 'getNumTxData'. -getNumTransaction :: - (StoreReadExtra m) => Word64 -> m [Transaction] -getNumTransaction i = do - net <- getNetwork - ctx <- getCtx - map (toTransaction net ctx) <$> getNumTxData i +getNumTransaction :: StoreRead -> Word64 -> IO [Transaction] +getNumTransaction r i = map (toTransaction r.net r.ctx) <$> r.getNumTxData i -- | First block in the main chain whose timestamp is at or after the given time, -- or 'Nothing' if there is none. -blockAtOrAfter :: - (MonadIO m, StoreReadExtra m) => - Chain -> - UnixTime -> - m (Maybe BlockData) -blockAtOrAfter ch q = runMaybeT $ do - net <- lift getNetwork - x <- MaybeT $ liftIO $ runReaderT (firstGreaterOrEqual net f) ch - MaybeT $ getBlock $ headerHash x.header +blockAtOrAfter :: StoreRead -> Chain -> UnixTime -> IO (Maybe BlockData) +blockAtOrAfter r ch q = + chainRunHeaders ch (firstGreaterOrEqual r.net f) >>= \case + Nothing -> return Nothing + Just x -> r.getBlock (headerHash x.header) where + f :: (BlockHeaders n) => BlockNode -> n Ordering f x = let t = fromIntegral x.header.timestamp in return $ t `compare` q -- | Last block in the main chain whose timestamp is at or before the given time, -- or 'Nothing' if there is none. -blockAtOrBefore :: - (MonadIO m, StoreReadExtra m) => - Chain -> - UnixTime -> - m (Maybe BlockData) -blockAtOrBefore ch q = runMaybeT $ do - net <- lift getNetwork - x <- MaybeT $ liftIO $ runReaderT (lastSmallerOrEqual net f) ch - MaybeT $ getBlock $ headerHash x.header +blockAtOrBefore :: StoreRead -> Chain -> UnixTime -> IO (Maybe BlockData) +blockAtOrBefore r ch q = + chainRunHeaders ch (lastSmallerOrEqual r.net f) >>= \case + Nothing -> return Nothing + Just x -> r.getBlock (headerHash x.header) where + f :: (BlockHeaders n) => BlockNode -> n Ordering f x = let t = fromIntegral x.header.timestamp in return $ t `compare` q -- | First block in the main chain whose median time past is at or after the given -- time, or 'Nothing' if there is none. -blockAtOrAfterMTP :: - (MonadIO m, StoreReadExtra m) => - Chain -> - UnixTime -> - m (Maybe BlockData) -blockAtOrAfterMTP ch q = runMaybeT $ do - net <- lift getNetwork - x <- MaybeT $ liftIO $ runReaderT (firstGreaterOrEqual net f) ch - MaybeT $ getBlock $ headerHash x.header +blockAtOrAfterMTP :: StoreRead -> Chain -> UnixTime -> IO (Maybe BlockData) +blockAtOrAfterMTP r ch q = + chainRunHeaders ch (firstGreaterOrEqual r.net f) >>= \case + Nothing -> return Nothing + Just x -> r.getBlock (headerHash x.header) where + f :: (BlockHeaders n) => BlockNode -> n Ordering f x = do t <- fromIntegral <$> mtp x return $ t `compare` q @@ -478,8 +501,8 @@ nub' :: (Hashable a) => [a] -> [a] nub' = H.toList . H.fromList --- | A 'forever' that stays a flat loop in any monad. 'forever' sequences --- with @*>@; monad-logger's @LoggingT@ leaves @*>@ at its default +-- | A 'Control.Monad.forever' that stays a flat loop in any monad. +-- 'Control.Monad.forever' sequences with @*>@; monad-logger's @LoggingT@ leaves @*>@ at its default -- @(id <$ a) <*> b@ and @ReaderT@ defines @>>@ as @*>@, so a loop that is -- polymorphic in its monad and not specialised by GHC keeps an @<*>@ -- continuation frame and two thunks per iteration for its whole lifetime. @@ -491,12 +514,12 @@ {-# INLINE loopForever #-} -- | Current time in microseconds since the Unix epoch. -microseconds :: (MonadIO m) => m Integer +microseconds :: IO Integer microseconds = let f t = toInteger (systemSeconds t) * 1000000 + toInteger (systemNanoseconds t) `div` 1000 - in liftIO $ f <$> getSystemTime + in f <$> getSystemTime -- | Stream every result of a paged query, fetching one page at a time. -- @@ -536,48 +559,74 @@ [] -> return () ls -> mapM_ yield ls >> go l' (last ls) --- | Merge streams sorted in decreasing order into one stream sorted in decreasing --- order, dropping duplicates. +-- | Merge streams sorted in decreasing order of a key into one stream sorted +-- in decreasing order of that key, dropping items whose key is the same as +-- the one before. The key must be the order the streams are really sorted +-- in: an item that comes out of order in its stream can be emitted twice. +-- +-- Use 'txRefKey' for transactions and 'unspentKey' for unspent outputs: they +-- are the order the database and the cache both keep, including the order of +-- ties between mempool transactions that arrived in the same second. joinDescStreams :: - (Monad m, Ord a) => + (Monad m, Ord k) => + (a -> k) -> [ConduitT () a m ()] -> ConduitT () a m () -joinDescStreams xs = do +joinDescStreams key xs = do let ss = map sealConduitT xs go Nothing =<< g ss where - j (x, y) = (,[x]) <$> y + j (x, y) = (\v -> (key v, [(v, x)])) <$> y g ss = let l = mapMaybe j <$> lift (traverse ($$++ await) ss) in Map.fromListWith (++) <$> l go m mp = case Map.lookupMax mp of Nothing -> return () - Just (x, ss) -> do + Just (k, vss) -> do case m of - Nothing -> yield x - Just x' - | x == x' -> return () - | otherwise -> yield x - mp1 <- g ss + Just k' | k == k' -> return () + _ -> yield (fst (last vss)) + mp1 <- g (map snd vss) let mp2 = Map.deleteMax mp mp' = Map.unionWith (++) mp1 mp2 - go (Just x) mp' + go (Just k) mp' +-- | Order of transaction references, newest first when sorted in decreasing +-- order: by block position, and between mempool transactions that arrived in +-- the same second, by the bytes of their hashes in increasing order. +-- +-- The tie order is not the derived 'Ord' of 'TxRef', which would sort the +-- hashes in decreasing order. It is the order of the database keys, which +-- serialize the hash after the block position, and of the Redis sorted sets +-- of the cache, which break ties between equal scores by the bytes of the +-- member. Using it everywhere makes every source agree, so that merged pages +-- have no duplicates and the cache answers exactly like the database. +txRefKey :: TxRef -> (BlockRef, Down TxHash) +txRefKey t = (t.block, Down t.txid) + +-- | Order of unspent outputs, newest first when sorted in decreasing order: +-- by block position, then by the serialized output point in increasing +-- order. See 'txRefKey' for why the ties are broken by serialized bytes. +unspentKey :: Unspent -> (BlockRef, Down ByteString) +unspentKey u = (u.block, Down (encode u.outpoint)) + -- | Merge streams whose keys never increase, taking at most the given number -- of items from each stream ('Nothing': all of them). The items come out in -- groups of equal key, in decreasing order of key, and each group is sorted --- in decreasing order of the items themselves. So the output is the same as +-- in decreasing order of the second function, which must agree with the +-- first. So the output is the same as -- sorting the first items of every stream in decreasing order, but a stream -- is read only as far as the consumer needs: a consumer that stops after -- the first n items makes each stream be read only a little past its first -- n items, instead of to the end of its quota. mergeDescGroups :: - (Monad m, Ord a, Ord k) => + (Monad m, Ord o, Ord k) => (a -> k) -> + (a -> o) -> Maybe Word32 -> [ConduitT () a m ()] -> ConduitT () a m () -mergeDescGroups key quota streams = do +mergeDescGroups key order quota streams = do heads <- lift $ mapM (next quota . sealConduitT) streams go (insertAll (catMaybes heads) Map.empty) where @@ -601,5 +650,5 @@ Nothing -> return () Just ((Down k, hs), mp') -> do gs <- lift $ mapM (group k) hs - mapM_ yield (sortOn Down (concatMap fst gs)) + mapM_ yield (sortOn (Down . order) (concatMap fst gs)) go (insertAll (mapMaybe snd gs) mp') diff --git a/src/Haskoin/Store/Database/Mempool.hs b/src/Haskoin/Store/Database/Mempool.hs new file mode 100644 --- /dev/null +++ b/src/Haskoin/Store/Database/Mempool.hs @@ -0,0 +1,505 @@ +-- | +-- Module : Haskoin.Store.Database.Mempool +-- Copyright : (c) Haskoin Developers +-- License : MIT +-- Maintainer : jprupp@protonmail.ch +-- Stability : experimental +-- Portability : POSIX +-- +-- The mempool area of the layered layout of the database, and how it is +-- applied on top of the chain. The design, and the reasons for it, are in +-- @docs\/layered-database.md@. This is the layout that the store runs on, +-- since version 21. Its rules are checked by the tests of +-- "Haskoin.Store.Database.Migrate" against the answers of a database of +-- version 20, in which the mempool was mixed into the chain. The queries +-- that apply them are in "Haskoin.Store.Database.Query.Layered". +-- +-- = Two layers +-- +-- In the layered layout the column families of the chain hold only what +-- follows from the blocks of the main chain, and change only when a block is +-- imported or reverted. Everything about unconfirmed transactions is in two +-- column families of its own, 'mempoolCF' and 'mempoolAddrCF'. A query reads +-- the chain, reads what the mempool has for the same transaction, output or +-- address, and puts the two together. Emptying the mempool area leaves the +-- chain as it is, with an empty mempool on top. +-- +-- = Every key belongs to one transaction +-- +-- 'mempoolRecords' gives the keys that a mempool transaction contributes. +-- They depend on that transaction alone: on its inputs, with the outputs +-- they spend, which it carries with it, and on its outputs. The mempool area +-- is the union of the keys of its transactions. So a transaction enters the +-- mempool by writing its keys and leaves it by deleting them, in any order, +-- and when a block confirms some transactions and not their descendants, +-- nothing has to be worked out again for those that stay. +-- +-- The alternative is to keep, for the mempool, the same values that the +-- chain has: a balance, a list of unspent outputs. Such values depend on the +-- chain under them. A balance with the mempool applied is wrong as soon as a +-- block pays the address, and every block would have to find and correct +-- the values it made stale. The keys here say what the mempool does, not +-- what the result is, so they stay right whatever happens to the chain. +-- +-- What a query needs is worked out when it is answered, from the few entries +-- that the mempool has for an address, an t'AddressMempool': +-- +-- * an output that the mempool creates and does not spend is an unspent +-- output of the mempool ('mempoolUnspents'); +-- +-- * an output that the mempool spends and did not create belongs to the +-- chain, which still has it as unspent, and is left out of what the chain +-- says ('hiddenOutputs'); +-- +-- * an output that the mempool both creates and spends shows up in neither, +-- and only counts towards what the address received. +-- +-- = The summary of an address +-- +-- The entries of an address are few for nearly every address, and many +-- thousands for some. So each address that the mempool touches also has a +-- t'MemSummary', one key with what its entries add up to ('summarise'). A +-- balance is the balance of the chain and the summary ('applySummary'), and +-- the queries read the entries themselves only for lists, as far as a page +-- goes. +-- +-- The summary is not the key of one transaction, but it is a function of +-- the entries of its address and of nothing else, so it shares what makes +-- them safe: nothing that happens to the chain makes it wrong. +-- 'wrongSummaries' checks that, and 'rebuildSummaries' writes them all +-- again from the entries. +module Haskoin.Store.Database.Mempool + ( -- * What a transaction contributes + MemRecords (..), + mempoolRecords, + recordEntries, + insertRecordOps, + deleteRecordOps, + + -- * Reading the mempool area + AddressMempool (..), + getAddressMempool, + getAddressMempools, + getMempoolTx, + getMempoolSpenders, + wipeMempoolArea, + + -- * Applying the mempool on top of the chain + mempoolUnspents, + hiddenOutputs, + applyMempool, + mergeBalance, + + -- * The summary of an address + summarise, + summaryEntries, + applySummary, + summaryBalance, + getSummaries, + rebuildSummaries, + wrongSummaries, + addressArea, + ) +where + +import Conduit (runConduit, sinkList, (.|)) +import Data.ByteString (ByteString) +import Data.HashMap.Strict (HashMap) +import Data.HashMap.Strict qualified as HashMap +import Data.HashSet qualified as HashSet +import Data.IntMap.Strict (IntMap) +import Data.IntMap.Strict qualified as IntMap +import Data.Maybe (fromMaybe, isNothing, mapMaybe) +import Data.Serialize (Serialize, decode, encode) +import Data.Word (Word32, Word64) +import Database.RocksDB + ( BatchOp (..), + ColumnFamily, + DB, + Iterator, + getCF, + iterFirst, + iterKey, + iterNext, + multiGetCF, + withIterCF, + ) +import Database.RocksDB.Query + ( matching, + matchingAsListCF, + retrieveCF, + writeBatch, + ) +import Haskoin + ( Address, + Ctx, + Network, + OutPoint (..), + Tx (..), + TxHash, + TxIn (..), + TxOut (..), + eitherToMaybe, + nullOutPoint, + scriptToAddressBS, + txHash, + ) +import Haskoin.Store.Common (nub') +import Haskoin.Store.Data + ( Balance (..), + BlockRef (..), + Prev (..), + Spender (..), + TxData (..), + TxRef (..), + UnixTime, + Unspent (..), + zeroBalance, + ) +import Haskoin.Store.Database.Reader + ( DatabaseReader (..), + mempoolAddrCF, + mempoolCF, + ) +import Haskoin.Store.Database.Types + ( MemAddrKey (..), + MemAddrVal (..), + MemSpenderKey (..), + MemSummary (..), + MemTimeKey (..), + MemTxKey (..), + TxKey (..), + ) + +------------------------------------------------------------------------------- +-- What a transaction contributes +------------------------------------------------------------------------------- + +-- | What one mempool transaction contributes to the mempool area. +data MemRecords = MemRecords + { -- | hash of the transaction + txid :: !TxHash, + -- | time it entered the mempool: its place in the list of the mempool + -- and in the index by time + time :: !UnixTime, + -- | its body, without spenders and at a mempool position + body :: !TxData, + -- | the outputs it spends, each with the input that spends it + spends :: ![(OutPoint, Spender)], + -- | for each address it touches: the transaction itself, the outputs of + -- the address that it spends and the outputs that it pays to the + -- address + addresses :: ![(MemAddrKey, MemAddrVal)] + } + deriving (Eq, Show) + +-- | What a mempool transaction that entered the mempool at a time +-- contributes to the mempool area. +-- +-- It is a function of the transaction and that time and of nothing else: +-- not of the chain, and not of the other transactions in the mempool. The +-- body is stored without spenders, which have keys of their own, and as not +-- deleted. The flag for replace-by-fee is kept as given; it is the one +-- thing here that can depend on other transactions, because a transaction +-- inherits it from unconfirmed ancestors, and it is corrected when one of +-- them is confirmed. +mempoolRecords :: Network -> Ctx -> UnixTime -> TxData -> MemRecords +mempoolRecords net ctx time td = + MemRecords + { txid = h, + time, + body = (td :: TxData) {block = MemRef time, deleted = False, spenders = IntMap.empty}, + spends = [(op, Spender h k) | (k, op) <- spent], + addresses = + [(MemAddrTxKey a time h, MemAddrTxVal) | a <- touched] + <> [ (MemAddrSpentKey a op, MemAddrSpentVal p.value) + | (k, op) <- spent, + Just p <- [IntMap.lookup (fromIntegral k) td.prevs], + Just a <- [address p.script] + ] + <> [ (MemAddrOutKey a time (OutPoint h i), MemAddrOutVal o.value o.script) + | (i, o) <- zip [0 ..] td.tx.outputs, + Just a <- [address o.script] + ] + } + where + h = txHash td.tx + spent = [(k, i.outpoint) | (k, i) <- zip [0 :: Word32 ..] td.tx.inputs, i.outpoint /= nullOutPoint] + address = eitherToMaybe . scriptToAddressBS net ctx + touched = + nub' $ + mapMaybe (address . (.script)) (IntMap.elems td.prevs) + <> mapMaybe (address . (.script)) td.tx.outputs + +-- | The keys and values of a transaction, serialized, for each of the two +-- column families of the mempool area: the mempool column family first, +-- then the one of address entries. +recordEntries :: MemRecords -> ([(ByteString, ByteString)], [(ByteString, ByteString)]) +recordEntries r = + ( [ kv (MemTxKey r.txid) r.time, + kv (MemTimeKey r.time r.txid) (), + kv (TxKey r.txid) r.body + ] + <> [kv (MemSpenderKey op) s | (op, s) <- r.spends], + [kv k v | (k, v) <- r.addresses] + ) + where + kv :: (Serialize k, Serialize v) => k -> v -> (ByteString, ByteString) + kv k v = (encode k, encode v) + +-- | Operations that write the keys of a transaction to the mempool area. +insertRecordOps :: DB -> MemRecords -> [BatchOp] +insertRecordOps db r = + [PutCF (mempoolCF db) k v | (k, v) <- general] + <> [PutCF (mempoolAddrCF db) k v | (k, v) <- byAddress] + where + (general, byAddress) = recordEntries r + +-- | Operations that delete the keys of a transaction from the mempool area. +deleteRecordOps :: DB -> MemRecords -> [BatchOp] +deleteRecordOps db r = + [DelCF (mempoolCF db) k | (k, _) <- general] + <> [DelCF (mempoolAddrCF db) k | (k, _) <- byAddress] + where + (general, byAddress) = recordEntries r + +------------------------------------------------------------------------------- +-- Reading the mempool area +------------------------------------------------------------------------------- + +-- | What the mempool does at an address. It is small, usually empty, and +-- read with one scan of the entries of the address. +data AddressMempool = AddressMempool + { -- | mempool transactions that spend from or pay to the address, newest + -- first, in the order of 'Haskoin.Store.Common.txRefKey' + txs :: ![TxRef], + -- | outputs of the address that mempool transactions spend, with their + -- amounts, whether a block or the mempool created them + spent :: !(HashMap OutPoint Word64), + -- | outputs that mempool transactions pay to the address, whether the + -- mempool spends them or not, newest first, in the order of + -- 'Haskoin.Store.Common.unspentKey' + created :: ![Unspent] + } + deriving (Eq, Show) + +-- | What the mempool does at an address. +getAddressMempool :: DatabaseReader -> Address -> IO AddressMempool +getAddressMempool r a = withIterCF r.db (mempoolAddrCF r.db) (`addressMempool` a) + +-- | What the mempool does at each of some addresses, in their order. +-- +-- All of them are read through one iterator, which is moved to each address +-- in turn. A query about an extended public key asks about hundreds of +-- addresses, nearly all with nothing in the mempool; opening an iterator for +-- each would cost more than the reads, each of which stops at the filter. +getAddressMempools :: DatabaseReader -> [Address] -> IO [AddressMempool] +getAddressMempools _ [] = return [] +getAddressMempools r as = withIterCF r.db (mempoolAddrCF r.db) $ \it -> mapM (addressMempool it) as + +-- | What the mempool does at an address, read with an iterator on the +-- column family of the entries by address, which is left wherever the scan +-- ended. +addressMempool :: Iterator -> Address -> IO AddressMempool +addressMempool it a = do + rows <- runConduit $ matching it (MemAddrKeyA a) .| sinkList + return + AddressMempool + { txs = [TxRef {block = MemRef t, txid = h} | (MemAddrTxKey _ t h, _) <- rows], + spent = HashMap.fromList [(p, v) | (MemAddrSpentKey _ p, MemAddrSpentVal v) <- rows], + created = + [ Unspent {block = MemRef t, outpoint = p, value = v, script = s, address = Just a} + | (MemAddrOutKey _ t p, MemAddrOutVal v s) <- rows + ] + } + +-- | Body of a transaction that is in the mempool, without its spenders. +getMempoolTx :: DatabaseReader -> TxHash -> IO (Maybe TxData) +getMempoolTx r h = retrieveCF r.db (mempoolCF r.db) (TxKey h) + +-- | Mempool inputs that spend the outputs of a transaction, by output index. +-- The transaction may be confirmed or in the mempool. +getMempoolSpenders :: DatabaseReader -> TxHash -> IO (IntMap Spender) +getMempoolSpenders r h = do + rows <- matchingAsListCF r.db (mempoolCF r.db) (MemSpenderKeyS h) + return $ IntMap.fromList [(fromIntegral p.index, s) | (MemSpenderKey p, s) <- rows] + +-- | Delete every key of the mempool area, and say how many there were. The +-- chain is not touched: afterwards the database is that of a store whose +-- mempool is empty, as if every unconfirmed transaction had been deleted one +-- by one, except that it does not remember having seen them. +-- +-- This is all that wiping the mempool takes in the layered layout, and what +-- can be done if the mempool area is ever found to be wrong. +wipeMempoolArea :: DatabaseReader -> IO Int +wipeMempoolArea r = sum <$> mapM wipe [mempoolCF r.db, mempoolAddrCF r.db] + where + wipe cf = go 0 + where + go n = + firstKeys cf >>= \case + [] -> return n + ks -> writeBatch r.db (map (DelCF cf) ks) >> go (n + length ks) + firstKeys :: ColumnFamily -> IO [ByteString] + firstKeys cf = withIterCF r.db cf $ \it -> iterFirst it >> collect it (10000 :: Int) + collect _ 0 = return [] + collect it n = + iterKey it >>= \case + Nothing -> return [] + Just k -> iterNext it >> (k :) <$> collect it (n - 1) + +------------------------------------------------------------------------------- +-- Applying the mempool on top of the chain +------------------------------------------------------------------------------- + +-- | Outputs of an address that the mempool created and has not spent, +-- newest first. +mempoolUnspents :: AddressMempool -> [Unspent] +mempoolUnspents m = [u | u <- m.created, not (HashMap.member u.outpoint m.spent)] + +-- | Outputs of an address that the chain has as unspent and that the mempool +-- spends, with their amounts: those that the mempool spends and did not +-- create itself. +hiddenOutputs :: AddressMempool -> HashMap OutPoint Word64 +hiddenOutputs m = HashMap.filterWithKey (\p _ -> not (HashSet.member p made)) m.spent + where + made = HashSet.fromList (map (.outpoint) m.created) + +-- | The balance that the chain has for an address, with what the mempool +-- does at the address applied: the balance as the API gives it. +-- +-- As in version 20, an output of a block that a mempool transaction spends no +-- longer counts as confirmed balance, and the unconfirmed balance is what +-- the mempool pays to the address and has not spent. +-- +-- The amounts taken from the chain can never be more than it has, as long +-- as every output that the mempool spends exists. If they ever are, the +-- result stops at zero rather than wrapping around. +applyMempool :: Balance -> AddressMempool -> Balance +applyMempool c m = applySummary c (summarise m) + +-- | Balance of an address as the API gives it, from its balance in the +-- chain, if it has one, and what the mempool does at it ('applyMempool'). +-- 'Nothing' if the address was never used in either. +-- +-- Version 20 answers with a balance of zero, rather than with 'Nothing', +-- for an address whose only transactions were deleted from the mempool: it +-- leaves the balance that it wrote for them behind. The API shows an unknown +-- address as a balance of zero, so the two are the same to it. +mergeBalance :: Address -> Maybe Balance -> AddressMempool -> Maybe Balance +mergeBalance a chain m + | isNothing chain && null m.txs && HashMap.null m.spent && null m.created = Nothing + | otherwise = Just (applyMempool (fromMaybe (zeroBalance a) chain) m) + +------------------------------------------------------------------------------- +-- The summary of an address +------------------------------------------------------------------------------- + +-- | What the entries of an address add up to. +summarise :: AddressMempool -> MemSummary +summarise m = + MemSummary + { txs = fromIntegral (length m.txs), + paid = sum (map (.value) m.created), + paidCount = fromIntegral (length m.created), + spent = sum (HashMap.elems m.spent), + spentCount = fromIntegral (HashMap.size m.spent), + both = sum (map (.value) inside), + bothCount = fromIntegral (length inside) + } + where + inside = [u | u <- m.created, HashMap.member u.outpoint m.spent] + +-- | The summaries that go with some entries by address, which may be of +-- many addresses: what the column family must have next to them, for the +-- migration, for repairs and for the tests. +summaryEntries :: [(MemAddrKey, MemAddrVal)] -> [(MemAddrKey, MemAddrVal)] +summaryEntries rows = + [ (MemAddrSumKey a, MemAddrSumVal (summarise m)) + | (a, m) <- HashMap.toList (HashMap.fromListWith (flip merge) (mapMaybe single rows)) + ] + where + entries ts sp cr = AddressMempool {txs = ts, spent = sp, created = cr} + merge x y = entries (x.txs <> y.txs) (x.spent <> y.spent) (x.created <> y.created) + single = \case + (MemAddrTxKey a t h, _) -> Just (a, entries [TxRef {block = MemRef t, txid = h}] HashMap.empty []) + (MemAddrSpentKey a p, MemAddrSpentVal v) -> Just (a, entries [] (HashMap.singleton p v) []) + (MemAddrOutKey a t p, MemAddrOutVal v s) -> + let u = Unspent {block = MemRef t, outpoint = p, value = v, script = s, address = Just a} + in Just (a, entries [] HashMap.empty [u]) + _ -> Nothing + +-- | The balance that the chain has for an address with the summary of what +-- the mempool does at it applied: what 'applyMempool' gives, from the +-- summary instead of the entries. +applySummary :: Balance -> MemSummary -> Balance +applySummary c s = + Balance + { address = c.address, + confirmed = c.confirmed `minus` (s.spent `minus` s.both), + unconfirmed = c.unconfirmed + (s.paid `minus` s.both), + utxo = (c.utxo `minus` (s.spentCount `minus` s.bothCount)) + (s.paidCount `minus` s.bothCount), + txs = c.txs + s.txs, + received = c.received + s.paid + } + where + minus x y = if y > x then 0 else x - y + +-- | Balance of an address as the API gives it, from its balance in the +-- chain and its summary in the mempool, either of which it may not have: +-- what 'mergeBalance' gives, without reading the entries. +summaryBalance :: Address -> Maybe Balance -> Maybe MemSummary -> Maybe Balance +summaryBalance _ chain Nothing = chain +summaryBalance a chain (Just s) = Just (applySummary (fromMaybe (zeroBalance a) chain) s) + +-- | The summaries of addresses, in their order, read by key with one +-- multi-get: 'Nothing' for an address that the mempool does not touch, +-- which is nearly all of them, and which the filter of the column family +-- answers. +getSummaries :: DatabaseReader -> [Address] -> IO [Maybe MemSummary] +getSummaries r as = + map (>>= decoded) <$> case map (encode . MemAddrSumKey) as of + [] -> return [] + -- one key is cheaper to read by itself than in a multi-get + [key] -> pure <$> getCF r.db (mempoolAddrCF r.db) key + keys -> multiGetCF r.db (mempoolAddrCF r.db) keys + where + decoded bytes = case decode bytes of + Right (MemAddrSumVal s) -> Just s + _ -> Nothing + +-- | The addresses whose summary is not what their entries add up to, each +-- with the summary that it should have and the one that it has. There are +-- none unless something is broken: this is what the tests hold the rules +-- to after every operation. +wrongSummaries :: DatabaseReader -> IO [(MemAddrKey, Maybe MemAddrVal, Maybe MemAddrVal)] +wrongSummaries r = do + rows <- matchingAsListCF r.db (mempoolAddrCF r.db) MemAddrKeyS + let found = HashMap.fromList [(k, v) | (k@MemAddrSumKey {}, v) <- rows] + expected = HashMap.fromList (summaryEntries rows) + return + [ (k, HashMap.lookup k expected, HashMap.lookup k found) + | k <- HashMap.keys (HashMap.union expected found), + HashMap.lookup k expected /= HashMap.lookup k found + ] + +-- | Everything that the column family of entries by address holds for a +-- mempool of some transactions, serialized, in no order: the entries of +-- each, and the summaries of the addresses that they touch. +addressArea :: [MemRecords] -> [(ByteString, ByteString)] +addressArea records = [(encode k, encode v) | (k, v) <- entries <> summaryEntries entries] + where + entries = concatMap (.addresses) records + +-- | Work every summary out again from the entries, and say how many +-- addresses have one. The migration does this once everything is moved, and +-- it is what puts the summaries right if they are ever in doubt. +rebuildSummaries :: DatabaseReader -> IO Int +rebuildSummaries r = do + rows <- matchingAsListCF r.db cf MemAddrKeyS + let old = [DelCF cf (encode k) | (k@MemAddrSumKey {}, _ :: MemAddrVal) <- rows] + new = summaryEntries rows + writeBatch r.db (old <> [PutCF cf (encode k) (encode v) | (k, v) <- new]) + return (length new) + where + cf = mempoolAddrCF r.db diff --git a/src/Haskoin/Store/Database/Migrate.hs b/src/Haskoin/Store/Database/Migrate.hs new file mode 100644 --- /dev/null +++ b/src/Haskoin/Store/Database/Migrate.hs @@ -0,0 +1,678 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE MultiWayIf #-} + +-- | +-- Module : Haskoin.Store.Database.Migrate +-- Copyright : (c) Haskoin Developers +-- License : MIT +-- Maintainer : jprupp@protonmail.ch +-- Stability : experimental +-- Portability : POSIX +-- +-- Migration of a database of version 20 to the layered layout, version 21, +-- of @docs\/layered-database.md@: the column families of the chain are left +-- with nothing from the mempool, and the mempool gets an area of its own +-- ("Haskoin.Store.Database.Mempool"). +-- +-- The store runs it when it opens a database ('upgradeDatabase'). It is +-- what makes the change of layout possible without syncing the chain again. +-- +-- = What it does +-- +-- In version 20 a mempool transaction is written into the indices of the +-- chain: its body, the entries of its addresses, its outputs as unspent, the +-- outputs it spends as spent, with itself as their spender in the bodies of +-- the transactions that created them, and all of it in the balances. The +-- migration takes each mempool transaction out of those indices, exactly as +-- deleting it does in version 20, and writes it to the mempool area instead. +-- When it is done, the chain's column families hold what they would hold if +-- the mempool had been wiped, and the mempool area holds the mempool. +-- +-- It reads and writes only what the mempool touches, so it takes a time in +-- proportion to the mempool, not to the chain: about what wiping the +-- mempool takes in version 20. +-- +-- = Why its own rules +-- +-- Taking a transaction out of the indices of version 20 is what +-- "Haskoin.Store.Logic" does today when it deletes one. The migration does +-- not call that code: the rules of the store will change with the layout, +-- and a migration has to go on reading version 20 as it was. It carries the +-- few rules it needs, and the tests check them against "Haskoin.Store.Logic" +-- while both exist. +-- +-- = Safe to interrupt +-- +-- A mempool can hold hundreds of thousands of transactions, too many for one +-- write, so the migration works in batches. Each batch is one atomic write +-- that moves whole transactions, descendants before the transactions they +-- spend. After any batch the database is a valid mix: the transactions +-- already moved are in the mempool area, and the others are still in the +-- chain's indices, as a database of version 20 with a smaller mempool. The +-- migration can stop there and carry on later. +-- +-- The first write sets the new version and a marker, t'MigrationKey', so +-- that a store of version 20 refuses the database from then on and a store +-- that knows the new layout carries the migration on. The last write +-- removes the marker. Before the first write everything is read once, so +-- that a database that the migration cannot handle is refused untouched. +-- +-- = Version 22: records of transactions that are written once +-- +-- Version 21 still had two things in the record of a confirmed +-- transaction that were not settled by the block that confirmed it: +-- +-- * __its time__, which was the time at which the store first saw it in +-- its mempool, if it had, and so another on each store; +-- +-- * __the spenders of its outputs__, which were written into the record +-- as later blocks spent them, and taken out when such a block was +-- reverted: the same on every store, but a record that was read and +-- written whole again for each of its outputs, for as long as it had +-- one unspent. +-- +-- From version 22 a confirmed transaction has the time of its block, the +-- spenders of its outputs are under keys of their own +-- as t'Haskoin.Store.Database.Types.SpenderKey' says, and its record is written +-- when a block confirms it and deleted if that block is reverted, and +-- nothing else ('Haskoin.Store.Logic.Layered.importBlock'). +-- 'migrateRecords' brings the records that are there already to that: it +-- gives each the time of its block, and moves its spenders to their keys. +-- It reads every transaction, and writes nearly every one, since most +-- have an output that was spent, so it takes a time in proportion to the +-- chain: 'upgradeDatabase' says how far it is as it goes. Each write does +-- whole transactions, the keys with the record that they come out of, and +-- running it again skips what is done, so it can be interrupted and +-- started over. +module Haskoin.Store.Database.Migrate + ( upgradeDatabase, + currentVersion, + migrateRecords, + layeredVersion, + Migration (..), + MigrationError (..), + MigrationOptions (..), + defaultMigrationOptions, + migrateLayered, + migrateLayeredWith, + ) +where + +import Control.Monad (forM_, unless, void, when) +import Data.Default (def) +import Data.HashMap.Strict (HashMap) +import Data.HashMap.Strict qualified as HashMap +import Data.HashSet (HashSet) +import Data.HashSet qualified as HashSet +import Data.IntMap.Strict qualified as IntMap +import Data.Maybe (isJust, mapMaybe) +import Data.Serialize (decode, encode) +import Data.String.Conversions (cs) +import Data.Text (Text) +import Data.Word (Word32, Word64) +import Database.RocksDB + ( BatchOp, + IterConfig (..), + getCF, + iterEntry, + iterFirst, + iterGetError, + iterNext, + withIterConfig, + ) +import Database.RocksDB.Query + ( deleteOp, + deleteOpCF, + insertOp, + insertOpCF, + matchingAsListCF, + retrieve, + retrieveCF, + writeBatch, + ) +import Haskoin + ( Address, + BlockHeader (..), + OutPoint (..), + Tx (..), + TxHash, + TxIn (..), + TxOut (..), + eitherToMaybe, + nullOutPoint, + scriptToAddressBS, + txHash, + txHashToHex, + ) +import Haskoin.Store.Common (nub') +import Haskoin.Store.Data + ( BlockData (..), + BlockRef (..), + Prev (..), + Spender (..), + TxData (..), + TxRef (..), + UnixTime, + confirmed, + ) +import Haskoin.Store.Database.Mempool (insertRecordOps, mempoolRecords, rebuildSummaries) +import Haskoin.Store.Database.Query qualified as Q +import Haskoin.Store.Database.Reader + ( DatabaseReader (..), + addrOutCF, + addrTxCF, + balanceCF, + initRocksDB, + mempoolCF, + spenderCF, + txCF, + unspentCF, + ) +import Haskoin.Store.Database.Types + ( AddrOutKey (..), + AddrTxKey (..), + BalKey (..), + BalVal (..), + MemTxKey (..), + MigrationKey (..), + OutVal (..), + SpenderKey (..), + SpenderVal (..), + TxKey (..), + UnspentKey (..), + UnspentVal (..), + VersionKey (..), + spenderGroup, + ) +import UnliftIO + ( Exception, + IORef, + modifyIORef', + newIORef, + readIORef, + throwIO, + writeIORef, + ) + +-- | Version of the layered layout as it was first written, with the time +-- at which a store first saw a transaction kept in the chain. +layeredVersion :: Word32 +layeredVersion = 21 + +-- | Version that the store runs on: the layered layout, with the time of +-- its block for every confirmed transaction. +currentVersion :: Word32 +currentVersion = 22 + +-- | Version that the migration starts from. +mixedVersion :: Word32 +mixedVersion = 20 + +-- | What a migration did. +data Migration = Migration + { -- | mempool transactions moved to the mempool area by this run + moved :: !Int, + -- | writes to the database that moved them + batches :: !Int, + -- | mempool transactions checked at the end, moved by this run or by + -- an earlier one that was interrupted + checked :: !Int, + -- | records of confirmed transactions that this run wrote again, with + -- the time of their block and without the spenders of their outputs + rewritten :: !Int + } + deriving (Eq, Show) + +-- | Why a migration refused a database, or stopped. +data MigrationError + = -- | the database is of a version that this migration does not start + -- from, or has none + UnknownVersion !(Maybe Word32) + | -- | the database is not as its version says it should be; nothing was + -- written for the transaction that showed it + Inconsistent !Text + deriving (Eq, Show, Exception) + +-- | How to run a migration. +data MigrationOptions = MigrationOptions + { -- | mempool transactions to move in each write + chunk :: !Int, + -- | called after each write with the number of transactions moved so + -- far; the tests interrupt the migration from here + afterBatch :: Int -> IO (), + -- | where to say what is going on + report :: Text -> IO () + } + +-- | A thousand transactions in each write, the size of the batches that +-- wipe the mempool in version 20, and nothing said. +defaultMigrationOptions :: MigrationOptions +defaultMigrationOptions = + MigrationOptions + { chunk = 1000, + afterBatch = \_ -> return (), + report = \_ -> return () + } + +-- | Bring a database opened with +-- 'Haskoin.Store.Database.Reader.withLayeredReader' to the layout that the +-- store runs on, whatever it was, telling a function what is being done: +-- a new database gets the current version, one of version 18 or 19 is +-- first brought to version 20 as it always was, one of version 20 is +-- migrated to the layered layout ('migrateLayered'), and one of version 21 +-- gets the time of its block for every confirmed transaction +-- ('migrateRecords'), each from the start or after an earlier run that was +-- interrupted. Throws a 'MigrationError' for any other version. +-- +-- This is the point of no return for a database of an older version: a +-- store older than the layout refuses it afterwards. +upgradeDatabase :: (Text -> IO ()) -> DatabaseReader -> IO Migration +upgradeDatabase report r = do + version <- retrieve r.db VersionKey + marker <- retrieve r.db MigrationKey :: IO (Maybe Word32) + case version of + Nothing -> do + writeBatch r.db [insertOp VersionKey currentVersion] + return nothing + Just v + | v == 18 || v == 19 -> do + report $ "Upgrading the database from version " <> cs (show v) <> " to " <> cs (show mixedVersion) + initRocksDB r + layered >>= times + | v == currentVersion && marker == Nothing -> return nothing + -- the times were being set when the store last stopped + | v == currentVersion && marker == Just layeredVersion -> times nothing + | v == currentVersion -> throwIO (UnknownVersion version) + Just (_ :: Word32) -> layered >>= times + where + nothing = Migration {moved = 0, batches = 0, checked = 0, rewritten = 0} + layered = migrateLayeredWith defaultMigrationOptions {report = report} r + times done = do + rewritten <- migrateRecords report r + return (done :: Migration) {rewritten} + +-- | Bring the records of the confirmed transactions of a database of +-- version 21 to what version 22 writes, and make the database one of that +-- version; or carry that on in a database where it was interrupted. Each +-- record gets the time of its block, and the spenders of its outputs go +-- from the record to keys of their own. Says how many records it wrote. +-- Throws a 'MigrationError' for a database of another version, and for +-- one with a confirmed transaction at a height where the main chain has +-- no block. +-- +-- Every record is read, and nearly every one is written: the whole of the +-- largest column family, which on a database of Bitcoin is many hours, +-- and room on the disk for a second copy of it until RocksDB has +-- compacted the first away. A function is told how far it is, every +-- million transactions. +-- +-- The first write sets the new version and the marker of a migration under +-- way; the last removes the marker. In between each write does some +-- thousand transactions, each with its keys, and a database that is half +-- done is a valid mix of both kinds of record. Starting again reads from +-- the beginning and skips what is done. +migrateRecords :: (Text -> IO ()) -> DatabaseReader -> IO Int +migrateRecords report r = do + version <- retrieve db VersionKey + marker <- retrieve db MigrationKey :: IO (Maybe Word32) + if + | version == Just layeredVersion && marker == Nothing -> do + report "Making the record of every confirmed transaction one that is written once: this reads them all" + writeBatch db [insertOp VersionKey currentVersion, insertOp MigrationKey layeredVersion] + run + | version == Just currentVersion && marker == Just layeredVersion -> do + report "Carrying on with the records of confirmed transactions, from the first" + run + | version == Just currentVersion && marker == Nothing -> return 0 + | otherwise -> throwIO (UnknownVersion version) + where + db = r.db + run = do + times <- newIORef IntMap.empty + pending <- newIORef [] + scanned <- newIORef (0 :: Int) + changed <- newIORef (0 :: Int) + let write = do + ops <- readIORef pending + unless (null ops) (writeBatch db ops) + writeIORef pending [] + -- the time of the block of the main chain at a height + timeAt :: Word32 -> IO Word64 + timeAt height = + IntMap.lookup (fromIntegral height) <$> readIORef times >>= \case + Just t -> return t + Nothing -> do + blocks <- Q.getBlocksAtHeight r height >>= mapM (Q.getBlock r) + case [b | Just b <- blocks, b.main] of + [b] -> do + let t = fromIntegral b.header.timestamp + t <$ modifyIORef' times (IntMap.insert (fromIntegral height) t) + _ -> throwIO (Inconsistent ("No block of the main chain at height " <> cs (show height))) + one (key, value) = case (decode key, decode value) of + (Right (TxKey h), Right (td :: TxData)) -> do + case td.block of + BlockRef {height} | not td.deleted -> do + t <- timeAt height + -- the spenders of its outputs get keys of their own, + -- in the write that takes them out of the record + let grouped = + IntMap.fromListWith + IntMap.union + [ (i `div` fromIntegral spenderGroup, IntMap.singleton i s) + | (i, s) <- IntMap.toList td.spenders + ] + keys = + [ insertOpCF (spenderCF db) (SpenderKey h (fromIntegral g)) (SpenderVal m) + | (g, m) <- IntMap.toList grouped + ] + -- a confirmed transaction cannot be replaced, and the + -- rules write it so: one that says otherwise is put right + record = (td :: TxData) {timestamp = t, spenders = IntMap.empty, rbf = False} + when (td.timestamp /= t || td.rbf || not (null keys)) $ do + modifyIORef' pending ((insertOpCF (txCF db) (TxKey h) record : keys) <>) + modifyIORef' changed (+ 1) + n <- length <$> readIORef pending + when (n >= 4000) write + _ -> return () + n <- readIORef scanned + writeIORef scanned (n + 1) + when ((n + 1) `mod` 1000000 == 0) $ do + c <- readIORef changed + report $ cs (show (n + 1)) <> " transactions read, " <> cs (show c) <> " written again" + -- the short keys of the column family are not transactions + _ -> return () + go it = + iterEntry it >>= \case + Nothing -> iterGetError it >>= mapM_ (throwIO . Inconsistent . cs . show) + Just row -> one row >> iterNext it >> go it + -- every transaction, whatever its prefix: the column family has a + -- prefix for its filters, and an iterator there promises the keys of + -- one prefix only unless it is asked for the order of them all + withIterConfig db (Just (txCF db)) def {totalOrderSeek = True} (\it -> iterFirst it >> go it) + write + writeBatch db [deleteOp MigrationKey] + c <- readIORef changed + n <- readIORef scanned + report $ cs (show c) <> " of " <> cs (show n) <> " records of transactions written again" + return c + +-- | Migrate a database of version 20, opened with +-- 'Haskoin.Store.Database.Reader.withLayeredReader', to the layered layout, +-- or carry on a migration that was interrupted. Does nothing to a database +-- that is already there. Throws a 'MigrationError' otherwise. +migrateLayered :: DatabaseReader -> IO Migration +migrateLayered = migrateLayeredWith defaultMigrationOptions + +-- | 'migrateLayered' with options. +migrateLayeredWith :: MigrationOptions -> DatabaseReader -> IO Migration +migrateLayeredWith opts r = do + version <- retrieve db VersionKey + marker <- retrieve db MigrationKey :: IO (Maybe Word32) + if + -- a database that is past this migration, whatever came after it + | version == Just layeredVersion && marker == Nothing -> + return Migration {moved = 0, batches = 0, checked = 0, rewritten = 0} + | version == Just currentVersion -> + return Migration {moved = 0, batches = 0, checked = 0, rewritten = 0} + | version == Just layeredVersion && marker == Just mixedVersion -> do + opts.report "Carrying on with the migration to the layered layout" + run + | version == Just mixedVersion -> do + listed <- mempoolList + mapM_ (preflight r) listed + opts.report $ "Moving " <> cs (show (length listed)) <> " mempool transactions to their own area" + -- from here on a store of version 20 refuses the database + writeBatch db [insertOp VersionKey layeredVersion, insertOp MigrationKey mixedVersion] + run + | otherwise -> throwIO (UnknownVersion version) + where + db = r.db + mempoolList = do + rows <- matchingAsListCF db (mempoolCF db) MemTxKeyS + return [h | (MemTxKey h, _ :: UnixTime) <- rows] + run = do + env <- newEnv opts r + listed <- mempoolList + mapM_ (moveTx env) listed + flush env + mapM_ (verify r) listed + -- the summaries are worked out from the entries, all at once: doing it + -- again after an interruption gives the same + void (rebuildSummaries r) + writeBatch db [deleteOp MigrationKey] + moved <- readIORef env.total + batches <- readIORef env.written + opts.report $ "Moved " <> cs (show moved) <> " mempool transactions" + return Migration {moved, batches, checked = length listed, rewritten = 0} + +------------------------------------------------------------------------------- +-- A batch +------------------------------------------------------------------------------- + +-- | A migration under way, and the batch that it is building: what it will +-- write, with the last value of everything that is read again before the +-- write. +data Env = Env + { reader :: !DatabaseReader, + options :: !MigrationOptions, + -- | bodies in the chain's column family that the batch changes; + -- 'Nothing' for one that it removes + bodies :: !(IORef (HashMap TxHash (Maybe TxData))), + -- | balances in the chain's column family that the batch changes + balances :: !(IORef (HashMap Address BalVal)), + -- | everything else that the batch writes, newest first: each of these + -- keys is written without being read, and in this order + ops :: !(IORef [BatchOp]), + -- | transactions that the batch moves + moving :: !(IORef (HashSet TxHash)), + -- | transactions moved by this run + total :: !(IORef Int), + -- | batches written by this run + written :: !(IORef Int) + } + +-- | A migration that has moved nothing yet, with an empty batch. +newEnv :: MigrationOptions -> DatabaseReader -> IO Env +newEnv options reader = do + bodies <- newIORef HashMap.empty + balances <- newIORef HashMap.empty + ops <- newIORef [] + moving <- newIORef HashSet.empty + total <- newIORef 0 + written <- newIORef 0 + return Env {reader, options, bodies, balances, ops, moving, total, written} + +-- | Body of a transaction in the chain's column family, as the batch leaves +-- it. +chainBody :: Env -> TxHash -> IO (Maybe TxData) +chainBody env h = + HashMap.lookup h <$> readIORef env.bodies >>= \case + Just changed -> return changed + Nothing -> retrieveCF db (txCF db) (TxKey h) + where + db = env.reader.db + +-- | Change the balance of an address in the chain's column family, or stop +-- if the change cannot be made. +change :: Env -> Address -> (BalVal -> Either Text BalVal) -> IO () +change env a f = do + current <- + HashMap.lookup a <$> readIORef env.balances >>= \case + Just b -> return b + Nothing -> maybe def id <$> retrieveCF db (balanceCF db) (BalKey a) + new <- either (throwIO . Inconsistent) return (f current) + modifyIORef' env.balances (HashMap.insert a new) + where + db = env.reader.db + +-- | Add an operation to the batch. +op :: Env -> BatchOp -> IO () +op env o = modifyIORef' env.ops (o :) + +-- | Write the batch, and start another. +flush :: Env -> IO () +flush env = do + count <- HashSet.size <$> readIORef env.moving + unless (count == 0) $ do + others <- reverse <$> readIORef env.ops + bodies <- HashMap.toList <$> readIORef env.bodies + balances <- HashMap.toList <$> readIORef env.balances + writeBatch db $ + others + <> [maybe (deleteOpCF (txCF db) (TxKey h)) (insertOpCF (txCF db) (TxKey h)) b | (h, b) <- bodies] + <> [balanceOp a b | (a, b) <- balances] + writeIORef env.ops [] + writeIORef env.bodies HashMap.empty + writeIORef env.balances HashMap.empty + writeIORef env.moving HashSet.empty + modifyIORef' env.written (+ 1) + readIORef env.total >>= env.options.afterBatch + where + db = env.reader.db + -- an address that only the mempool used has no balance in the chain + balanceOp a b + | b == def = deleteOpCF (balanceCF db) (BalKey a) + | otherwise = insertOpCF (balanceCF db) (BalKey a) b + +------------------------------------------------------------------------------- +-- Moving a transaction +------------------------------------------------------------------------------- + +-- | Whether a transaction is already in the mempool area. +isMoved :: Env -> TxHash -> IO Bool +isMoved env h = do + now <- HashSet.member h <$> readIORef env.moving + if now then return True else isJust <$> getCF db (mempoolCF db) (encode (TxKey h)) + where + db = env.reader.db + +-- | Move a mempool transaction, and first the mempool transactions that +-- spend its outputs: taking those out is what makes its outputs unspent +-- again, as they must be for its own turn. +moveTx :: Env -> TxHash -> IO () +moveTx env h = do + done <- isMoved env h + unless done $ do + td <- mempoolBody + forM_ (nub' (map (.txid) (IntMap.elems td.spenders))) (moveTx env) + -- read again: moving the spenders removed them from the body + td' <- mempoolBody + unless (IntMap.null td'.spenders) . stop $ "still has spenders after they were moved" + time <- case td'.block of + MemRef t -> return t + BlockRef {} -> stop "is confirmed" + takeOut env td' + mapM_ (op env) (insertRecordOps db (mempoolRecords env.reader.net env.reader.ctx time td')) + modifyIORef' env.moving (HashSet.insert h) + modifyIORef' env.total (+ 1) + count <- HashSet.size <$> readIORef env.moving + when (count >= env.options.chunk) (flush env) + where + db = env.reader.db + stop :: Text -> IO a + stop why = throwIO . Inconsistent $ "Mempool transaction " <> txHashToHex h <> " " <> why + mempoolBody = + chainBody env h >>= \case + Just td | not td.deleted, not (confirmed td.block) -> return td + Just td | td.deleted -> stop "is marked as deleted" + Just _ -> stop "is confirmed" + Nothing -> stop "has no body" + +-- | Take a mempool transaction that nothing spends out of the indices of +-- the chain, as deleting it does in version 20, except that its body is +-- removed and not kept as deleted: it is not deleted, it moves. +takeOut :: Env -> TxData -> IO () +takeOut env td = do + -- the entries of its addresses, and their counts of transactions + forM_ touched $ \a -> do + op env (deleteOpCF (addrTxCF db) (AddrTxKey a TxRef {block = td.block, txid = h})) + change env a $ \b -> do + n <- less "transactions" b.txs 1 + return (b :: BalVal) {txs = n} + -- its outputs, all of them unspent by now + forM_ (zip [0 ..] td.tx.outputs) $ \(i, o) -> do + let p = OutPoint h i + op env (deleteOpCF (unspentCF db) (UnspentKey p)) + forM_ (address o.script) $ \a -> do + op env (deleteOpCF (addrOutCF db) (AddrOutKey a td.block p)) + change env a $ \b -> do + u <- less "unconfirmed balance" b.unconfirmed o.value + n <- less "unspent outputs" b.utxo 1 + rx <- less "amount received" b.received o.value + return (b :: BalVal) {unconfirmed = u, utxo = n, received = rx} + -- the outputs it spends are unspent again, as before it came + forM_ [i.outpoint | i <- td.tx.inputs, i.outpoint /= nullOutPoint] $ \p -> do + parent <- + chainBody env p.hash >>= \case + Just t | not t.deleted -> return t + _ -> stop $ "spends an output of " <> txHashToHex p.hash <> ", which is not there" + o <- case drop (fromIntegral p.index) parent.tx.outputs of + o : _ -> return o + [] -> stop $ "spends an output that " <> txHashToHex p.hash <> " does not have" + modifyIORef' env.bodies . HashMap.insert p.hash . Just $ + (parent :: TxData) {spenders = IntMap.delete (fromIntegral p.index) parent.spenders} + op env . insertOpCF (unspentCF db) (UnspentKey p) $ + UnspentVal {block = parent.block, value = o.value, script = o.script} + forM_ (address o.script) $ \a -> do + op env (insertOpCF (addrOutCF db) (AddrOutKey a parent.block p) (OutVal o.value o.script)) + change env a $ \b -> + return $ + if confirmed parent.block + then (b :: BalVal) {confirmed = b.confirmed + o.value, utxo = b.utxo + 1} + else (b :: BalVal) {unconfirmed = b.unconfirmed + o.value, utxo = b.utxo + 1} + -- its body leaves the chain's column family + modifyIORef' env.bodies (HashMap.insert h Nothing) + where + db = env.reader.db + h = txHash td.tx + address = eitherToMaybe . scriptToAddressBS env.reader.net env.reader.ctx + touched = + nub' $ + mapMaybe (address . (.script)) (IntMap.elems td.prevs) + <> mapMaybe (address . (.script)) td.tx.outputs + stop :: Text -> IO a + stop why = throwIO . Inconsistent $ "Mempool transaction " <> txHashToHex h <> " " <> why + -- a balance never goes below zero in a database that is in order + less :: Text -> Word64 -> Word64 -> Either Text Word64 + less what x y + | y > x = Left $ "Taking out " <> txHashToHex h <> " would make the " <> what <> " of an address negative" + | otherwise = Right (x - y) + +------------------------------------------------------------------------------- +-- Checks +------------------------------------------------------------------------------- + +-- | Before anything is written: a transaction that the mempool lists must +-- have the body of a mempool transaction. +preflight :: DatabaseReader -> TxHash -> IO () +preflight r h = + (retrieveCF r.db (txCF r.db) (TxKey h) :: IO (Maybe TxData)) >>= \case + Just td | not td.deleted, not (confirmed td.block) -> return () + _ -> + throwIO . Inconsistent $ + "The mempool lists " <> txHashToHex h <> ", which is not an unconfirmed transaction" + +-- | After everything is moved: a mempool transaction is in the mempool +-- area and has left nothing in the chain's column families, and every +-- output it spends is there to be spent, in the mempool or unspent in the +-- chain. +verify :: DatabaseReader -> TxHash -> IO () +verify r h = do + td <- + retrieveCF db (mempoolCF db) (TxKey h) >>= \case + Just td -> return (td :: TxData) + Nothing -> stop "is not in the mempool area" + inChain <- isJust <$> getCF db (txCF db) (encode (TxKey h)) + when inChain $ stop "still has a body in the chain" + forM_ (zip [0 ..] td.tx.outputs) $ \(i, _) -> do + left <- isJust <$> getCF db (unspentCF db) (encode (UnspentKey (OutPoint h i))) + when left $ stop "still has an unspent output in the chain" + forM_ [i.outpoint | i <- td.tx.inputs, i.outpoint /= nullOutPoint] $ \p -> do + inMempool <- isJust <$> getCF db (mempoolCF db) (encode (TxKey p.hash)) + unspent <- isJust <$> getCF db (unspentCF db) (encode (UnspentKey p)) + unless (inMempool || unspent) . void . stop $ + "spends an output of " <> txHashToHex p.hash <> " that is neither in the mempool nor unspent" + where + db = r.db + stop :: Text -> IO a + stop why = throwIO . Inconsistent $ "After the migration, mempool transaction " <> txHashToHex h <> " " <> why diff --git a/src/Haskoin/Store/Database/Query.hs b/src/Haskoin/Store/Database/Query.hs new file mode 100644 --- /dev/null +++ b/src/Haskoin/Store/Database/Query.hs @@ -0,0 +1,696 @@ +-- | +-- Module : Haskoin.Store.Database.Query +-- Copyright : (c) Haskoin Developers +-- License : MIT +-- Maintainer : jprupp@protonmail.ch +-- Stability : experimental +-- Portability : POSIX +-- +-- Queries against the RocksDB database, as plain functions in 'IO' that take +-- the 'DatabaseReader' as their first argument. +-- +-- These read one layer. On a database of version 20 that is everything, +-- the mempool included, and the tests use them so. On the layout that the +-- store runs on, they give what the chain has and nothing of the mempool, +-- but for its list: "Haskoin.Store.Database.Query.Layered" calls them for +-- the chain's part of its answers, and is what the store answers with. +-- +-- = Why plain functions +-- +-- The queries used to be the methods of two classes, run in +-- @ReaderT DatabaseReader@, and reached the web server through more layers of +-- @ReaderT@ for the cache. Every caller then +-- had to live in a stack of monad transformers to ask the database anything, +-- and every layer had to lift or re-implement every method. A function that +-- takes the reader and runs in 'IO' can be called from anywhere, needs no +-- instance, and says in its type exactly what it reads from. +-- +-- Streams are still conduits, run in 'IO': they are a good fit for merging the +-- sorted indices of many addresses and reading only as far as a page needs. +module Haskoin.Store.Database.Query + ( -- * All of them + databaseRead, + + -- * Blocks + getBestBlock, + getBlocksAtHeight, + getBlock, + + -- * Transactions + getTxData, + getTxRecord, + getManyTxData, + getChainSpender, + getChainSpenders, + withChainSpenders, + getNumTxData, + getSpender, + + -- * Addresses + getBalance, + getBalances, + getUnspent, + getAddressTxs, + getAddressesTxs, + getAddressUnspents, + getAddressesUnspents, + + -- * Mempool + getMempool, + getMempoolPage, + getMempoolBefore, + + -- * Extended public keys + xPubBals, + xPubUnspents, + xPubTxs, + xPubTxCount, + getAddressesTxCount, + + -- * Building blocks + + -- | What the queries above are made of, for the queries of the layered + -- layout in "Haskoin.Store.Database.Query.Layered", which read the same + -- column families for the part of their answers that is in the chain. + count, + withManyIters, + retrieveManyCF, + joinConduits, + usedAddresses, + ) +where + +import Conduit + ( ConduitT, + concatC, + concatMapC, + dropWhileC, + lift, + mapC, + runConduit, + sinkList, + takeC, + takeWhileC, + yield, + (.|), + ) +import Control.Monad (forM, (>=>)) +import Data.Bits ((.&.)) +import Data.ByteString qualified as BS +import Data.Default (def) +import Data.Functor ((<&>)) +import Data.IntMap.Strict qualified as IntMap +import Data.Map.Strict qualified as Map +import Data.Maybe (catMaybes, listToMaybe) +import Data.Ord (Down (..)) +import Data.Serialize (Serialize, decode, encode) +import Data.Word (Word32, Word64) +import Database.RocksDB + ( ColumnFamily, + DB, + IterConfig (..), + Iterator, + createIteratorConfig, + getCF, + iterKey, + iterLast, + iterNext, + iterPrev, + iterSeek, + iterValid, + multiGetCF, + prefixUpperBound, + withIterCF, + withIterConfig, + ) +import Database.RocksDB.Query + ( matching, + matchingAsListCF, + matchingSkip, + retrieve, + retrieveCF, + ) +import Haskoin + ( Address, + BlockHash, + BlockHeight, + OutPoint (..), + Tx (..), + TxHash, + ) +import Haskoin.Store.Common + ( Limits (..), + Start (..), + StoreRead (..), + applyLimitsC, + deOffset, + joinDescStreams, + mergeDescGroups, + notDeleted, + scanXPubBals, + txRefKey, + unspentKey, + ) +import Haskoin.Store.Data +import Haskoin.Store.Database.Reader +import Haskoin.Store.Database.Types +import System.Metrics.StatsD (decrementGauge, incrementCounter, incrementGauge) +import UnliftIO + ( bracket, + bracket_, + mask_, + modifyIORef', + newIORef, + readIORef, + ) + +-- | The queries of a database as a 'StoreRead', for code that takes its +-- queries as a value, such as the web server, which puts the Redis cache in +-- front of some of them. Transactions that were deleted are left out +-- ('notDeleted'); the functions of this module still return them, for the +-- code that imports transactions. +databaseRead :: DatabaseReader -> StoreRead +databaseRead r = + StoreRead + { net = r.net, + ctx = r.ctx, + getBestBlock = getBestBlock r, + getBlocksAtHeight = getBlocksAtHeight r, + getBlock = getBlock r, + getTxData = fmap notDeleted . getTxData r, + getManyTxData = fmap (map notDeleted) . getManyTxData r, + getSpender = getSpender r, + getBalance = getBalance r, + getUnspent = getUnspent r, + getMempool = getMempool r, + getMempoolPage = getMempoolPage r, + getAddressesTxs = getAddressesTxs r, + getAddressesUnspents = getAddressesUnspents r, + initialGap = r.initGap, + maxGap = r.maxGap, + getNumTxData = fmap (filter (not . (.deleted))) . getNumTxData r, + getBalances = getBalances r, + getAddressTxs = getAddressTxs r, + getAddressUnspents = getAddressUnspents r, + xPubBals = xPubBals r, + xPubUnspents = \_ -> xPubUnspents r, + xPubTxs = \_ -> xPubTxs r, + xPubTxCount = \_ -> xPubTxCount r, + getAddressesTxCount = getAddressesTxCount r + } + +-- | Count something in the metrics, if they are enabled. +count :: DatabaseReader -> (DataMetrics -> IO ()) -> IO () +count r f = mapM_ f r.metrics + +------------------------------------------------------------------------------- +-- Blocks +------------------------------------------------------------------------------- + +-- | Hash of the best block, if the database has any. +getBestBlock :: DatabaseReader -> IO (Maybe BlockHash) +getBestBlock r = do + count r $ \s -> incrementCounter s.dataBestCount 1 + retrieve r.db BestKey + +-- | Hashes of the blocks at a height, of the main chain and of side chains. +getBlocksAtHeight :: DatabaseReader -> BlockHeight -> IO [BlockHash] +getBlocksAtHeight r h = + retrieveCF r.db (heightCF r.db) (HeightKey h) >>= \case + Nothing -> return [] + Just ls -> do + count r $ \s -> incrementCounter s.dataBlockCount (length ls) + return ls + +-- | Data of a block. +getBlock :: DatabaseReader -> BlockHash -> IO (Maybe BlockData) +getBlock r h = + retrieveCF r.db (blockCF r.db) (BlockKey h) >>= \case + Nothing -> return Nothing + Just b -> do + count r $ \s -> incrementCounter s.dataBlockCount 1 + return (Just b) + +------------------------------------------------------------------------------- +-- Transactions +------------------------------------------------------------------------------- + +-- | Data of a transaction, including deleted ones, with the inputs of +-- blocks that spend its outputs. +getTxData :: DatabaseReader -> TxHash -> IO (Maybe TxData) +getTxData r th = + getTxRecord r th >>= \case + Nothing -> return Nothing + Just t -> do + count r $ \s -> incrementCounter s.dataTxCount 1 + listToMaybe <$> withChainSpenders r [(th, t)] + +-- | The record of a transaction as the database has it, including deleted +-- ones. Since version 22 the spenders of its outputs are not in it +-- ('getChainSpenders'); a database of version 20 or 21 has them there. +-- This is what the rules that write the database read: they must not +-- write back what was read from somewhere else. +getTxRecord :: DatabaseReader -> TxHash -> IO (Maybe TxData) +getTxRecord r th = retrieveCF r.db (txCF r.db) (TxKey th) + +-- | Data of many transactions, in the order of the hashes, read with one +-- multi-get, with the inputs of blocks that spend their outputs. +getManyTxData :: DatabaseReader -> [TxHash] -> IO [Maybe TxData] +getManyTxData r ths = do + found <- retrieveManyCF r.db (txCF r.db) (map TxKey ths) + count r $ \s -> incrementCounter s.dataTxCount (length (catMaybes found)) + spent <- withChainSpenders r [(h, td) | (h, Just td) <- zip ths found] + return (fill found spent) + where + fill (Just _ : more) (td : tds) = Just td : fill more tds + fill (Nothing : more) tds = Nothing : fill more tds + fill _ _ = [] + +-- | The input of a block that spends an output, if one does: one read by +-- key, of the group of outputs that it is in, in a database of version 22. +getChainSpender :: DatabaseReader -> OutPoint -> IO (Maybe Spender) +getChainSpender r p = + retrieveCF r.db (spenderCF r.db) (spenderKey p) <&> \case + Just (SpenderVal m) -> IntMap.lookup (fromIntegral p.index) m + Nothing -> Nothing + +-- | The inputs of blocks that spend the outputs of a transaction, by +-- output, read with one scan of the keys of the transaction. +getChainSpenders :: DatabaseReader -> TxHash -> IO (IntMap.IntMap Spender) +getChainSpenders r h = do + rows <- matchingAsListCF r.db (spenderCF r.db) (SpenderKeyS h) + return (IntMap.unions [m | (_ :: SpenderKey, SpenderVal m) <- rows]) + +-- | Records of transactions, with the inputs of blocks that spend their +-- outputs added to whatever spenders the records have themselves, which +-- those of a database older than version 22 do. +-- +-- The spenders are read by the keys of the groups of outputs, all the +-- groups of all the transactions in one multi-get. A group is sixteen +-- outputs, so nearly every transaction is one key, and a page of a +-- hundred transactions is one more read of a hundred keys. A scan would +-- need an iterator for each transaction, at ten microseconds apiece. Only +-- a transaction with more groups than 'wideTx' is scanned, so that a +-- payout to thousands is not hundreds of keys to ask for. +-- +-- Each record comes with the hash of its transaction, which whoever read +-- it by its key has: working it out again from the record is two rounds +-- of SHA-256 over the whole transaction, and cost more than everything +-- else here together when this was first written without it. +withChainSpenders :: DatabaseReader -> [(TxHash, TxData)] -> IO [TxData] +withChainSpenders _ [] = return [] +withChainSpenders r tds = do + let groups td = (fromIntegral (length td.tx.outputs) + spenderGroup - 1) `div` spenderGroup + keys (h, td) = [SpenderKey h g | g <- take (fromIntegral (groups td)) [0 ..]] + narrow (_, td) = groups td <= wideTx + asked = concatMap keys (filter narrow tds) + found <- case asked of + [] -> return [] + _ -> retrieveManyCF r.db (spenderCF r.db) asked + let byKey = Map.fromList [(k, m) | (k, Just (SpenderVal m)) <- zip asked found] + keyed x = IntMap.unions [m | k <- keys x, Just m <- [Map.lookup k byKey]] + forM tds $ \x@(h, td) -> do + chain <- if narrow x then return (keyed x) else getChainSpenders r h + return (td :: TxData) {spenders = IntMap.union td.spenders chain} + +-- | The number of groups of outputs above which the spenders of a +-- transaction are read with a scan instead of by key. +wideTx :: Word32 +wideTx = 16 + +-- | Transactions whose hash, read as a number, matches a short identifier of +-- the Blockchain.info API. There may be more than one. +getNumTxData :: DatabaseReader -> Word64 -> IO [TxData] +getNumTxData r i = do + let (sk, w) = decodeTxKey i + ls <- matchingAsListCF r.db (txCF r.db) (TxKeyS sk) + let f h = + let bs = encode h + b = BS.head (BS.drop 6 bs) + w' = b .&. 0xf8 + in w == w' + txs = [(h, td) | (TxKey h, td) <- ls, f h] + count r $ \s -> incrementCounter s.dataTxCount (length txs) + withChainSpenders r txs + +-- | Transaction that spends an output, if any: by its key, or, in a +-- database older than version 22, from the record of the transaction that +-- made the output. +getSpender :: DatabaseReader -> OutPoint -> IO (Maybe Spender) +getSpender r op = + getChainSpender r op >>= \case + Just s -> return (Just s) + Nothing -> + getTxRecord r op.hash <&> \case + Nothing -> Nothing + Just td -> IntMap.lookup (fromIntegral op.index) td.spenders + +------------------------------------------------------------------------------- +-- Addresses +------------------------------------------------------------------------------- + +-- | Balance of an address, if it was ever used. +getBalance :: DatabaseReader -> Address -> IO (Maybe Balance) +getBalance r a = do + count r $ \s -> incrementCounter s.dataBalanceCount 1 + fmap (valToBalance a) <$> retrieveCF r.db (balanceCF r.db) (BalKey a) + +-- | Balances of addresses, in the same order, read with one multi-get. +-- Addresses never used get a zero balance. +getBalances :: DatabaseReader -> [Address] -> IO [Balance] +getBalances _ [] = return [] +getBalances r as = do + count r $ \s -> incrementCounter s.dataBalanceCount (length as) + vals <- retrieveManyCF r.db (balanceCF r.db) (map BalKey as) + return (zipWith f as vals) + where + f a Nothing = zeroBalance a + f a (Just v) = valToBalance a v + +-- | Unspent output, if it exists and is unspent. +getUnspent :: DatabaseReader -> OutPoint -> IO (Maybe Unspent) +getUnspent r p = + retrieveCF r.db (unspentCF r.db) (UnspentKey p) >>= \case + Nothing -> return Nothing + Just val -> do + count r $ \s -> incrementCounter s.dataUnspentCount 1 + return (Just (valToUnspent r.net r.ctx p val)) + +-- | Transactions of an address, newest first. +getAddressTxs :: DatabaseReader -> Address -> Limits -> IO [TxRef] +getAddressTxs r a limits = do + txs <- withIterCFStat r (addrTxCF r.db) (AddrTxKeyA a) $ \it -> + runConduit $ + addressConduit r a limits.start it + .| applyLimitsC limits + .| sinkList + count r $ \s -> incrementCounter s.dataAddrTxCount (length txs) + return txs + +-- | Transactions of any of the addresses, newest first, each once. +getAddressesTxs :: DatabaseReader -> [Address] -> Limits -> IO [TxRef] +getAddressesTxs r addrs limits = + withManyIters r (addrTxCF r.db) (map AddrTxKeyA addrs) $ \its -> do + txs <- joinConduits txRefKey (zipWith (\a -> addressConduit r a limits.start) addrs its) limits + count r $ \s -> incrementCounter s.dataAddrTxCount (length txs) + return txs + +-- | Unspent outputs of an address, newest first. +getAddressUnspents :: DatabaseReader -> Address -> Limits -> IO [Unspent] +getAddressUnspents r a limits = do + us <- withIterCFStat r (addrOutCF r.db) (AddrOutKeyA a) $ \it -> + runConduit $ + unspentConduit r a limits.start it + .| applyLimitsC limits + .| sinkList + count r $ \s -> incrementCounter s.dataUnspentCount (length us) + return us + +-- | Unspent outputs of any of the addresses, newest first. +getAddressesUnspents :: DatabaseReader -> [Address] -> Limits -> IO [Unspent] +getAddressesUnspents r addrs limits = + withManyIters r (addrOutCF r.db) (map AddrOutKeyA addrs) $ \its -> do + uns <- joinConduits unspentKey (zipWith (\a -> unspentConduit r a limits.start) addrs its) limits + count r $ \s -> incrementCounter s.dataUnspentCount (length uns) + return uns + +-- | Stream the transactions of an address, newest first, from a starting point. +-- If the start is a transaction that is not found, nothing is streamed. +addressConduit :: + DatabaseReader -> + Address -> + Maybe Start -> + Iterator -> + ConduitT i TxRef IO () +addressConduit r a s it = + pipe .| mapC (uncurry f) + where + f (AddrTxKey _ t) () = t + f _ _ = undefined + pipe = case s of + Nothing -> + matching it (AddrTxKeyA a) + Just (AtBlock bh) -> + matchingSkip it (AddrTxKeyA a) (AddrTxKeyB a (BlockRef bh maxBound)) + Just (AtTx txh) -> + lift (getTxRecord r txh) >>= \case + Just TxData {block = b@BlockRef {}} -> + matchingSkip it (AddrTxKeyA a) (AddrTxKeyB a b) + Just TxData {block = b@MemRef {}} -> + -- Mempool transactions that arrived in the same second are + -- keyed by hash, so seek to the time and drop those before it. + let start = txRefKey (TxRef b txh) + before (AddrTxKey _ t, ()) = txRefKey t > start + before _ = undefined + in matchingSkip it (AddrTxKeyA a) (AddrTxKeyB a b) + .| (dropWhileC before >> mapC id) + Nothing -> return () + +-- | Stream the unspent outputs of an address, newest first, from a starting +-- point. If the start is a transaction that is not found, nothing is streamed. +unspentConduit :: + DatabaseReader -> + Address -> + Maybe Start -> + Iterator -> + ConduitT i Unspent IO () +unspentConduit r a s it = + x .| mapC (uncurry (toUnspent r.net r.ctx)) .| concatC + where + x = case s of + Nothing -> + matching it (AddrOutKeyA a) + Just (AtBlock h) -> + matchingSkip it (AddrOutKeyA a) (AddrOutKeyB a (BlockRef h maxBound)) + Just (AtTx txh) -> + lift (getTxRecord r txh) >>= \case + Just TxData {block = b@BlockRef {}} -> + matchingSkip it (AddrOutKeyA a) (AddrOutKeyB a b) + Just TxData {block = b@MemRef {}} -> + -- The outputs of the start transaction come first among those + -- of the same second whose hashes are not smaller. + let start = (b, Down (encode (OutPoint txh 0))) + before (AddrOutKey _ ref p, _) = (ref, Down (encode p)) > start + before _ = undefined + in matchingSkip it (AddrOutKeyA a) (AddrOutKeyB a b) + .| (dropWhileC before >> mapC id) + Nothing -> return () + +------------------------------------------------------------------------------- +-- Mempool +------------------------------------------------------------------------------- + +-- | The whole mempool, newest first. +getMempool :: DatabaseReader -> IO [(UnixTime, TxHash)] +getMempool r = getMempoolPage r def + +-- | Page of the mempool, newest first, from the offset and limit of the +-- 'Limits'; its start is ignored. Reads only the entries of the page from +-- the index by time. +getMempoolPage :: DatabaseReader -> Limits -> IO [(UnixTime, TxHash)] +getMempoolPage r limits = do + count r $ \s -> incrementCounter s.dataMempoolCount 1 + withIterCF r.db (mempoolCF r.db) $ \it -> + runConduit $ + mempoolNewestC it + .| applyLimitsC limits + .| sinkList + +-- | Mempool transactions that entered it before the given time, oldest +-- first, at most as many as given. Reads only those entries of the index. +getMempoolBefore :: DatabaseReader -> UnixTime -> Int -> IO [(UnixTime, TxHash)] +getMempoolBefore r time n = + withIterCF r.db (mempoolCF r.db) $ \it -> + runConduit $ + matching it MemTimeKeyS + .| concatMapC entry + .| takeWhileC ((< time) . fst) + .| takeC n + .| sinkList + where + entry (MemTimeKey t h, ()) = Just (t, h) + entry (MemTimeKeyS, ()) = Nothing + +-- | Mempool from the index by time, newest first. The index sorts last in +-- the mempool column family, so seek past its prefix and walk backwards +-- until a key is no longer in it. +mempoolNewestC :: Iterator -> ConduitT i (UnixTime, TxHash) IO () +mempoolNewestC it = do + lift $ do + -- 0x0c is the first prefix after the 0x0b of 'MemTimeKey' + iterSeek it (BS.singleton 0x0c) + iterValid it >>= \case + True -> iterPrev it + False -> iterLast it + go + where + go = + lift (iterKey it) >>= \case + Just k | Right (MemTimeKey t h) <- decode k -> do + yield (t, h) + lift (iterPrev it) + go + _ -> return () + +------------------------------------------------------------------------------- +-- Extended public keys +------------------------------------------------------------------------------- + +-- | Balances of the addresses of an extended public key, derived up to the +-- exact gap (see 'scanXPubBals'). +xPubBals :: DatabaseReader -> XPubSpec -> IO [XPubBal] +xPubBals r xpub = do + Derived ext chg <- derivedAddrs r xpub + bals <- scanXPubBals (getBalances r) r.initGap r.maxGap ext chg + count r $ \s -> incrementCounter s.dataXPubBals (length bals) + return bals + +-- | Unspent outputs of an extended public key, newest first, given its +-- balances from 'xPubBals'. +-- +-- The first unspent outputs of each address, at most offset plus limit of +-- them, sorted together. The addresses are read in step, so that each is +-- read only as far as the page needs, rather than decoding the whole quota +-- of every address to keep one page of it. +xPubUnspents :: DatabaseReader -> [XPubBal] -> Limits -> IO [XPubUnspent] +xPubUnspents r xbals limits = do + let quota = case (deOffset limits).limit of + 0 -> Nothing + l -> Just l + stream b it = + unspentConduit r b.balance.address limits.start it + .| mapC (\u -> XPubUnspent {path = b.path, unspent = u}) + us <- withManyIters r (addrOutCF r.db) (map (AddrOutKeyA . (.balance.address)) cs) $ \its -> + runConduit $ + mergeDescGroups (.unspent.block) (unspentKey . (.unspent)) quota (zipWith stream cs its) + .| applyLimitsC limits + .| sinkList + count r $ \s -> incrementCounter s.dataXPubUnspents (length us) + return us + where + cs = filter ((> 0) . (.balance.utxo)) xbals + +-- | Transactions of an extended public key, newest first, given its balances +-- from 'xPubBals'. +xPubTxs :: DatabaseReader -> [XPubBal] -> Limits -> IO [TxRef] +xPubTxs r xbals limits = do + txs <- getAddressesTxs r (usedAddresses xbals) limits + count r $ \s -> incrementCounter s.dataXPubTxs (length txs) + return txs + +-- | Number of transactions of an extended public key, given its balances +-- from 'xPubBals'. +-- +-- Each transaction is counted once even when it touches several addresses. +-- The entries of an address are sorted, and the same transaction has the same +-- key after the address prefix in every address, so the addresses are merged +-- by those raw key bytes and the distinct ones counted, without decoding any +-- key or reading any value. +xPubTxCount :: DatabaseReader -> [XPubBal] -> IO Word32 +xPubTxCount r xbals = do + count r $ \s -> incrementCounter s.dataXPubTxCount 1 + getAddressesTxCount r (usedAddresses xbals) + +-- | Number of distinct transactions of a set of addresses: each transaction +-- is counted once even when it touches several of them. It reads only the +-- keys of the index, once each, as 'xPubTxCount' does, so it costs about as +-- much as reading the references of the transactions once, and much less +-- than paging through them. +getAddressesTxCount :: DatabaseReader -> [Address] -> IO Word32 +getAddressesTxCount _ [] = return 0 +getAddressesTxCount r as = + withManyIters r (addrTxCF r.db) (map AddrTxKeyA as) $ \its -> + fromIntegral <$> countDistinctSuffixes (zip (map (encode . AddrTxKeyA) as) its) + +-- | Addresses of the balances that were ever used. +usedAddresses :: [XPubBal] -> [Address] +usedAddresses = map (.address) . filter (not . nullBalance) . map (.balance) + +-- | Number of distinct keys, after their prefix, in a set of iterators that +-- each walk the keys with one prefix, in order. +countDistinctSuffixes :: [(BS.ByteString, Iterator)] -> IO Int +countDistinctSuffixes streams = do + heads <- mapM start streams + go 0 (Map.fromListWith (<>) [(k, [x]) | (k, x) <- catMaybes heads]) + where + start x@(pfx, it) = iterSeek it pfx >> current x + current x@(pfx, it) = + iterKey it <&> \case + Just k | pfx `BS.isPrefixOf` k -> Just (BS.drop (BS.length pfx) k, x) + _ -> Nothing + advance x@(_, it) = iterNext it >> current x + go !n m = case Map.minViewWithKey m of + Nothing -> return n + Just ((_, xs), m') -> do + nexts <- catMaybes <$> mapM advance xs + go (n + 1) (foldr (\(k, x) -> Map.insertWith (<>) k [x]) m' nexts) + +------------------------------------------------------------------------------- +-- Iterators and multi-gets +------------------------------------------------------------------------------- + +-- | Run an action with an iterator on a column family, counting it in the +-- metrics. +-- +-- The iterator is for the keys that start with a prefix, and RocksDB +-- stops it where they end ('scanOf'). +withIterCFStat :: (Serialize k) => DatabaseReader -> ColumnFamily -> k -> (Iterator -> IO a) -> IO a +withIterCFStat r cf prefix f = + bracket_ (gauge r 1) (gauge r (-1)) $ withIterConfig r.db (Just cf) (scanOf prefix) f + +-- | An iterator for the keys that start with a prefix, such as those of one +-- address: one that RocksDB itself stops at the end of them. +-- +-- A scan that stops by looking at the key that it has reached makes +-- RocksDB find that key first, and if the keys after the prefix were +-- deleted, it steps over the marker of every one of them to get there. +-- With an upper bound it stops at the bound. The summary of the mempool +-- area and the layout of the chain keep such runs of deleted keys short as +-- things are, so this is for the day that they do not: after a +-- reorganisation that reverts many blocks, or a change of layout. +scanOf :: (Serialize k) => k -> IterConfig +scanOf prefix = def {upperBound = prefixUpperBound (encode prefix)} + +-- | Run an action with this many iterators on a column family. They are +-- opened and closed in a single bracket rather than one bracket each: each +-- bracket leaves a frame on the stack, and every call into RocksDB through +-- an iterator walks the stack, so with one bracket per address an xpub of a +-- hundred addresses made each step of each iterator a hundred times slower. +-- +-- There is one iterator for each of the prefixes given, in their order, +-- and each is bounded to the keys of its prefix ('scanOf'). +withManyIters :: (Serialize k) => DatabaseReader -> ColumnFamily -> [k] -> ([Iterator] -> IO a) -> IO a +withManyIters r cf prefixes f = + bracket_ (gauge r i) (gauge r (negate i)) $ + bracket (newIORef []) (readIORef >=> sequence_) $ \ref -> do + its <- forM prefixes $ \prefix -> mask_ $ do + (it, destroy) <- createIteratorConfig r.db (Just cf) (scanOf prefix) + modifyIORef' ref (destroy :) + return it + f its + where + i = length prefixes + +-- | Change the gauge of open iterators. +gauge :: DatabaseReader -> Int -> IO () +gauge r n = count r $ \s -> + if n >= 0 then incrementGauge s.dataIters n else decrementGauge s.dataIters (negate n) + +-- | Values of many keys of a column family, read with one multi-get, in +-- the order of the keys. +-- +-- One key is read by itself. A multi-get costs about as much as a read to +-- set up and a third of one for each key, as measured, so it is the slower +-- way to read one key, and most requests about one transaction or one +-- address ask for one. +retrieveManyCF :: (Serialize key, Serialize value) => DB -> ColumnFamily -> [key] -> IO [Maybe value] +retrieveManyCF _ _ [] = return [] +retrieveManyCF db cf [key] = pure . fmap (either error id . decode) <$> getCF db cf (encode key) +retrieveManyCF db cf keys = + map (fmap (either error id . decode)) <$> multiGetCF db cf (map encode keys) + +-- | Merge streams sorted newest first, drop duplicates, and apply the offset +-- and limit. +joinConduits :: (Ord k) => (o -> k) -> [ConduitT () o IO ()] -> Limits -> IO [o] +joinConduits key cs l = + runConduit $ joinDescStreams key cs .| applyLimitsC l .| sinkList diff --git a/src/Haskoin/Store/Database/Query/Layered.hs b/src/Haskoin/Store/Database/Query/Layered.hs new file mode 100644 --- /dev/null +++ b/src/Haskoin/Store/Database/Query/Layered.hs @@ -0,0 +1,807 @@ +-- | +-- Module : Haskoin.Store.Database.Query.Layered +-- Copyright : (c) Haskoin Developers +-- License : MIT +-- Maintainer : jprupp@protonmail.ch +-- Stability : experimental +-- Portability : POSIX +-- +-- The queries of "Haskoin.Store.Database.Query" for the layered layout of +-- the database, in which the chain and the mempool are kept apart; see +-- @docs\/layered-database.md@. These are the queries that the store +-- answers with. Each answers as the query of the same name answers on a +-- database of version 20, pages included. The tests check that, on +-- databases migrated from that version and on databases built by the rules +-- of "Haskoin.Store.Logic.Layered". +-- +-- = Two sources +-- +-- A query reads the column families of the chain, with the functions of +-- "Haskoin.Store.Database.Query", reads what the mempool area has for the +-- same transaction, output or address, with those of +-- "Haskoin.Store.Database.Mempool", and puts the two together. +-- +-- = Why a view +-- +-- The two reads must see the database at the same moment. A block could +-- confirm a transaction between them. Read from the mempool before the block +-- and from the chain after it, the transaction would be listed twice, and +-- its payment counted twice in a balance; read the other way around, it +-- would be missing. The queries of version 20 need no such care, because each of their +-- answers is one key or one scan. +-- +-- So every query takes a t'View', a snapshot of the database, and 'withView' +-- is the only way to get one: a query cannot be given the database itself by +-- mistake. The web server is meant to take one view for each request. That +-- also makes the several queries of a request agree with each other, which +-- they did not have to in version 20. +-- +-- = Pages +-- +-- Lists are ordered newest first, and unconfirmed transactions are newer +-- than any block. The list of an address is therefore what the mempool has +-- for it followed by what the chain has, and that is the sequence that the +-- single index of version 20 holds. A page is cut from it by the same +-- rules: where it starts, then the offset, then the limit. Both parts are +-- streamed, each from its own index, only as far as the page needs. +-- +-- = Reading no more than the answer +-- +-- Nearly every address has nothing in the mempool, and a few have thousands +-- of entries there. Each address that the mempool touches has a summary of +-- its entries, a t'MemSummary', which every query about an address reads +-- first, by key. A balance is the chain's balance with the summary applied. +-- A list reads the entries only of the addresses that have a summary, and +-- the summary says how many outputs the mempool spends, so that no more are +-- looked for. The first version of these queries scanned the entries of +-- every address for every question, which measured ten thousand times +-- slower for a busy address, and a hundred times slower for any address +-- after a block, when the scan steps over all that the block deleted. +module Haskoin.Store.Database.Query.Layered + ( -- * A view of the database + View, + withView, + layeredRead, + standaloneRead, + viewReader, + + -- * Parts shared with the queries of a fleet + From (..), + chainTxsC, + chainUnspentsC, + withSpenders, + + -- * Blocks + getBestBlock, + getBlocksAtHeight, + getBlock, + + -- * Transactions + getTxData, + getManyTxData, + getNumTxData, + getSpender, + + -- * Addresses + getBalance, + getBalances, + getUnspent, + getAddressTxs, + getAddressesTxs, + getAddressUnspents, + getAddressesUnspents, + + -- * Mempool + getMempool, + getMempoolPage, + + -- * Extended public keys + xPubBals, + xPubUnspents, + xPubTxs, + xPubTxCount, + getAddressesTxCount, + ) +where + +import Conduit + ( ConduitT, + await, + awaitForever, + concatMapC, + lift, + mapC, + runConduit, + sinkList, + yield, + yieldMany, + (.|), + ) +import Control.Monad (forM) +import Data.Bits ((.&.)) +import Data.ByteString qualified as BS +import Data.Functor ((<&>)) +import Data.HashMap.Strict (HashMap) +import Data.HashMap.Strict qualified as HashMap +import Data.HashSet qualified as HashSet +import Data.IntMap.Strict (IntMap) +import Data.IntMap.Strict qualified as IntMap +import Data.List (partition) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Maybe (catMaybes, isJust) +import Data.Serialize (Serialize, encode) +import Data.Word (Word32, Word64) +import Database.RocksDB (ColumnFamily, Iterator, multiGetCF, withSnapshot) +import Database.RocksDB.Query + ( matching, + matchingAsListCF, + matchingSkip, + retrieveCF, + ) +import Haskoin + ( Address, + BlockHash, + BlockHeight, + OutPoint (..), + Tx (..), + TxHash, + TxOut (..), + eitherToMaybe, + scriptToAddressBS, + ) +import Haskoin.Store.Common + ( Limits (..), + Start (..), + StoreRead (..), + applyLimitsC, + deOffset, + mergeDescGroups, + notDeleted, + scanXPubBals, + txRefKey, + unspentKey, + ) +import Haskoin.Store.Data + ( Balance (..), + BlockData, + BlockRef (..), + Spender, + TxData (..), + TxRef (..), + UnixTime, + Unspent (..), + XPubBal (..), + XPubSpec, + XPubUnspent (..), + ) +import Haskoin.Store.Database.Mempool qualified as M +import Haskoin.Store.Database.Query qualified as Q +import Haskoin.Store.Database.Reader + ( DataMetrics (..), + DatabaseReader (..), + Derived (..), + addrOutCF, + addrTxCF, + derivedAddrs, + mempoolAddrCF, + mempoolCF, + txCF, + ) +import Haskoin.Store.Database.Types + ( AddrOutKey (..), + AddrTxKey (..), + MemAddrKey (..), + MemAddrVal (..), + MemSpenderKey (..), + MemSummary (..), + OutVal, + TxKey (..), + decodeTxKey, + toUnspent, + ) +import System.Metrics.StatsD (incrementCounter) + +------------------------------------------------------------------------------- +-- A view of the database +------------------------------------------------------------------------------- + +-- | A database of the layered layout as it was at one moment: both of its +-- areas, read through one RocksDB snapshot. Whatever is written after the +-- view was taken, the queries on it go on answering from that moment. +newtype View = View DatabaseReader + +-- | The reader of a view: the database as it was at the moment of the +-- view. The queries of "Haskoin.Store.Database.Query" on it give what the +-- chain had then. +viewReader :: View -> DatabaseReader +viewReader (View r) = r + +-- | Run an action with a view of a database as it is now. +-- +-- Taking a view costs about a microsecond, so there is no reason to share +-- one between requests, and a reason not to: RocksDB keeps the data that a +-- view can see for as long as the view is open. +-- +-- The view, and anything made from it, such as the queries of 'layeredRead', +-- must not be used after the action returns: the snapshot is released then, +-- and RocksDB would be handed a pointer to freed memory. An action that +-- gives back something lazy or something that reads later, such as the body +-- of a streamed response, has to run inside. +withView :: DatabaseReader -> (View -> IO a) -> IO a +withView r action = withSnapshot r.db $ \snapshot -> action (View r {db = snapshot}) + +-- | The queries of a view as a t'StoreRead', for the web server, as +-- 'Q.databaseRead' gives those of a database of version 20. +layeredRead :: View -> StoreRead +layeredRead v@(View r) = + StoreRead + { net = r.net, + ctx = r.ctx, + getBestBlock = getBestBlock v, + getBlocksAtHeight = getBlocksAtHeight v, + getBlock = getBlock v, + getTxData = fmap notDeleted . getTxData v, + getManyTxData = fmap (map notDeleted) . getManyTxData v, + getSpender = getSpender v, + getBalance = getBalance v, + getUnspent = getUnspent v, + getMempool = getMempool v, + getMempoolPage = getMempoolPage v, + getAddressesTxs = getAddressesTxs v, + getAddressesUnspents = getAddressesUnspents v, + initialGap = r.initGap, + maxGap = r.maxGap, + getNumTxData = fmap (filter (not . (.deleted))) . getNumTxData v, + getBalances = getBalances v, + getAddressTxs = getAddressTxs v, + getAddressUnspents = getAddressUnspents v, + xPubBals = xPubBals v, + xPubUnspents = \_ -> xPubUnspents v, + xPubTxs = \_ -> xPubTxs v, + xPubTxCount = \_ -> xPubTxCount v, + getAddressesTxCount = getAddressesTxCount v + } + +-- | The queries of a database as a t'StoreRead', each on a view of its +-- own, taken when it is asked. For code that asks one thing at a time and +-- has no request to hold a view for. Queries asked one after the other may +-- see different moments, so what needs several of them to agree takes a +-- view with 'withView'. +standaloneRead :: DatabaseReader -> StoreRead +standaloneRead r = + StoreRead + { net = r.net, + ctx = r.ctx, + getBestBlock = one (.getBestBlock), + getBlocksAtHeight = \h -> one (\q -> q.getBlocksAtHeight h), + getBlock = \h -> one (\q -> q.getBlock h), + getTxData = \h -> one (\q -> q.getTxData h), + getManyTxData = \hs -> one (\q -> q.getManyTxData hs), + getSpender = \p -> one (\q -> q.getSpender p), + getBalance = \a -> one (\q -> q.getBalance a), + getUnspent = \p -> one (\q -> q.getUnspent p), + getMempool = one (.getMempool), + getMempoolPage = \l -> one (\q -> q.getMempoolPage l), + getAddressesTxs = \as l -> one (\q -> q.getAddressesTxs as l), + getAddressesUnspents = \as l -> one (\q -> q.getAddressesUnspents as l), + initialGap = r.initGap, + maxGap = r.maxGap, + getNumTxData = \n -> one (\q -> q.getNumTxData n), + getBalances = \as -> one (\q -> q.getBalances as), + getAddressTxs = \a l -> one (\q -> q.getAddressTxs a l), + getAddressUnspents = \a l -> one (\q -> q.getAddressUnspents a l), + xPubBals = \x -> one (\q -> q.xPubBals x), + xPubUnspents = \x bs l -> one (\q -> q.xPubUnspents x bs l), + xPubTxs = \x bs l -> one (\q -> q.xPubTxs x bs l), + xPubTxCount = \x bs -> one (\q -> q.xPubTxCount x bs), + getAddressesTxCount = \as -> one (\q -> q.getAddressesTxCount as) + } + where + one :: (StoreRead -> IO a) -> IO a + one f = withView r (f . layeredRead) + +------------------------------------------------------------------------------- +-- Blocks +------------------------------------------------------------------------------- + +-- | Hash of the best block, if the database has any. +getBestBlock :: View -> IO (Maybe BlockHash) +getBestBlock (View r) = Q.getBestBlock r + +-- | Hashes of the blocks at a height, of the main chain and of side chains. +getBlocksAtHeight :: View -> BlockHeight -> IO [BlockHash] +getBlocksAtHeight (View r) = Q.getBlocksAtHeight r + +-- | Data of a block. +getBlock :: View -> BlockHash -> IO (Maybe BlockData) +getBlock (View r) = Q.getBlock r + +------------------------------------------------------------------------------- +-- Transactions +------------------------------------------------------------------------------- + +-- | Data of a transaction, with the spenders of its outputs, those in blocks +-- and those in the mempool. A transaction in the mempool comes from the +-- mempool area, and a confirmed one from the chain. One that left the +-- mempool unconfirmed is not known: nothing is kept of it, and the bodies +-- that version 20 left in the chain for such transactions are passed over. +getTxData :: View -> TxHash -> IO (Maybe TxData) +getTxData v h = + getManyTxData v [h] <&> \case + [found] -> found + _ -> Nothing + +-- | Data of many transactions, in the order of the hashes. Each column +-- family that has to be read is read with one multi-get. +getManyTxData :: View -> [TxHash] -> IO [Maybe TxData] +getManyTxData (View r) hs = do + found <- bodies r hs + spent <- mempoolSpenders r (Map.toList found) + let tds = [withSpenders spent h <$> Map.lookup h found | h <- hs] + Q.count r $ \s -> incrementCounter s.dataTxCount (length (catMaybes tds)) + return tds + +-- | Transactions whose hash, read as a number, matches a short identifier of +-- the Blockchain.info API, in the order of their hashes. There may be more +-- than one. +getNumTxData :: View -> Word64 -> IO [TxData] +getNumTxData (View r) i = do + unconfirmed <- matchingAsListCF r.db (mempoolCF r.db) (TxKeyS prefix) + stored <- matchingAsListCF r.db (txCF r.db) (TxKeyS prefix) + let rows = [(h, td) | (TxKey h, td) <- stored] + chain <- zip (map fst rows) <$> Q.withChainSpenders r rows + let found = + preferred + (Map.fromList [(h, td) | (TxKey h, td) <- unconfirmed]) + (Map.fromList chain) + matches = filter (seventh . fst) (Map.toAscList found) + spent <- mempoolSpenders r matches + Q.count r $ \s -> incrementCounter s.dataTxCount (length matches) + return [withSpenders spent h td | (h, td) <- matches] + where + (prefix, bits) = decodeTxKey i + -- the keys match on the first six bytes of the hash; the identifier + -- also has the five high bits of the seventh + seventh h = BS.index (encode h) 6 .&. 0xf8 == bits + +-- | Input that spends an output, in the mempool or in a block. +getSpender :: View -> OutPoint -> IO (Maybe Spender) +getSpender (View r) p = + retrieveCF r.db (mempoolCF r.db) (MemSpenderKey p) >>= \case + Just s -> return (Just s) + Nothing -> Q.getChainSpender r p + +-- | The bodies of transactions by hash, each from where it is kept, with +-- the spenders that blocks give to its outputs and without those of the +-- mempool. +-- +-- The mempool area is asked first, although most transactions asked for are +-- confirmed: with its filter, finding that a transaction is not there costs +-- a fraction of reading a body, and the chain is then asked only for the +-- others. +bodies :: DatabaseReader -> [TxHash] -> IO (Map TxHash TxData) +bodies r hs = do + unconfirmed <- look (mempoolCF r.db) TxKey hs + chain <- look (txCF r.db) TxKey (filter (`Map.notMember` unconfirmed) hs) >>= spent + return (preferred unconfirmed chain) + where + -- the spenders that blocks give to the outputs of confirmed + -- transactions are under keys of their own + spent found = do + let rows = Map.toAscList found + Map.fromDistinctAscList . zip (map fst rows) <$> Q.withChainSpenders r rows + look :: (Serialize key) => ColumnFamily -> (TxHash -> key) -> [TxHash] -> IO (Map TxHash TxData) + look _ _ [] = return Map.empty + look cf key ks = + Map.fromList . catMaybes . zipWith (fmap . (,)) ks + <$> Q.retrieveManyCF r.db cf (map key ks) + +-- | The body to answer with for each transaction, given the bodies that the +-- mempool area has for transactions in the mempool and those that the +-- chain has. A transaction is in one place only. A body that version 20 +-- left in the chain for a transaction that it deleted is no body at all: +-- finding them all to delete them would mean reading every transaction of +-- the database, so they stay where they are and are passed over. +preferred :: Map TxHash TxData -> Map TxHash TxData -> Map TxHash TxData +preferred unconfirmed chain = unconfirmed <> Map.filter (not . (.deleted)) chain + +-- | The spenders that the mempool has for the outputs of transactions, +-- given their bodies as 'bodies' gives them. +-- +-- Only the outputs that no block spends are looked up, since the mempool +-- cannot spend the others: all of them with one multi-get, which the filter +-- of the column family answers for the many outputs that the mempool does +-- not spend. A transaction with more than 'scanFrom' such outputs has its +-- spenders read with a scan of their common prefix instead. +mempoolSpenders :: DatabaseReader -> [(TxHash, TxData)] -> IO (HashMap TxHash (IntMap Spender)) +mempoolSpenders r txs = do + found <- case points of + [] -> return [] + _ -> Q.retrieveManyCF r.db (mempoolCF r.db) (map MemSpenderKey points) + scanned <- mapM (\(h, _) -> (h,) <$> M.getMempoolSpenders r h) wide + return . HashMap.fromListWith IntMap.union $ + [(p.hash, IntMap.singleton (fromIntegral p.index) s) | (p, Just s) <- zip points found] + <> scanned + where + open :: [(TxHash, [Word32])] + open = + [ (h, [i | (i, _) <- zip [0 ..] td.tx.outputs, IntMap.notMember (fromIntegral i) td.spenders]) + | (h, td) <- txs, + not td.deleted + ] + (narrow, wide) = partition (null . drop scanFrom . snd) open + points = [OutPoint h i | (h, is) <- narrow, i <- is] + +-- | Number of outputs of a transaction above which the mempool spenders of +-- the transaction are read with a scan. A scan costs about as much as eight +-- lookups in a multi-get whatever it finds, by the measurements in +-- @docs\/layered-database.md@. +scanFrom :: Int +scanFrom = 8 + +-- | Add the spenders that the mempool has for the outputs of a transaction +-- to those in its body. +withSpenders :: HashMap TxHash (IntMap Spender) -> TxHash -> TxData -> TxData +withSpenders spent h td = case HashMap.lookup h spent of + Nothing -> td + Just unconfirmed -> (td :: TxData) {spenders = IntMap.union td.spenders unconfirmed} + +------------------------------------------------------------------------------- +-- Addresses +------------------------------------------------------------------------------- + +-- | Balance of an address, with the mempool applied. 'Nothing' if neither +-- the chain nor the mempool has anything for the address; see +-- 'M.mergeBalance' for where version 20 says zero instead. +-- +-- It is two reads by key, the balance of the chain and the summary of the +-- mempool, however much the mempool does at the address. +getBalance :: View -> Address -> IO (Maybe Balance) +getBalance (View r) a = M.summaryBalance a <$> Q.getBalance r a <*> (only <$> M.getSummaries r [a]) + where + only = \case + [s] -> s + _ -> Nothing + +-- | Balances of addresses, in the same order, with the mempool applied. +-- Addresses never used get a zero balance. Two multi-gets, one in each area. +getBalances :: View -> [Address] -> IO [Balance] +getBalances (View r) as = zipWith apply <$> Q.getBalances r as <*> M.getSummaries r as + where + apply c = maybe c (M.applySummary c) + +-- | Unspent output, if it exists and neither a block nor the mempool spends +-- it: one that the chain has, or one of a mempool transaction. +getUnspent :: View -> OutPoint -> IO (Maybe Unspent) +getUnspent (View r) p = + retrieveCF r.db (mempoolCF r.db) (MemSpenderKey p) >>= \case + Just (_ :: Spender) -> return Nothing + Nothing -> + Q.getUnspent r p >>= \case + Just u -> return (Just u) + Nothing -> (>>= output) <$> M.getMempoolTx r p.hash + where + output td = case drop (fromIntegral p.index) td.tx.outputs of + o : _ -> + Just + Unspent + { block = td.block, + outpoint = p, + value = o.value, + script = o.script, + address = eitherToMaybe (scriptToAddressBS r.net r.ctx o.script) + } + [] -> Nothing + +-- | Transactions of an address, newest first. +getAddressTxs :: View -> Address -> Limits -> IO [TxRef] +getAddressTxs v a = getAddressesTxs v [a] + +-- | Transactions of any of the addresses, newest first, each once. +getAddressesTxs :: View -> [Address] -> Limits -> IO [TxRef] +getAddressesTxs (View r) as limits = paged r limits $ \from -> do + txs <- withMempoolIters r from as (const True) $ \mempools -> + Q.withManyIters r (addrTxCF r.db) (map AddrTxKeyA as) $ \its -> + Q.joinConduits txRefKey (zipWith3 (addressTxsC from) as (map (fmap snd) mempools) its) limits + Q.count r $ \s -> incrementCounter s.dataAddrTxCount (length txs) + return txs + +-- | Unspent outputs of an address, newest first. +getAddressUnspents :: View -> Address -> Limits -> IO [Unspent] +getAddressUnspents v a = getAddressesUnspents v [a] + +-- | Unspent outputs of any of the addresses, newest first. +getAddressesUnspents :: View -> [Address] -> Limits -> IO [Unspent] +getAddressesUnspents (View r) as limits = paged r limits $ \from -> do + us <- withUnspentStreams r from as $ \streams -> + Q.joinConduits unspentKey streams limits + Q.count r $ \s -> incrementCounter s.dataUnspentCount (length us) + return us + +------------------------------------------------------------------------------- +-- Pages +------------------------------------------------------------------------------- + +-- | Where a page starts in a list that has the mempool's part first and the +-- chain's part after it. +data From + = -- | at the newest item + Top + | -- | in the mempool's part, at the transaction that entered the mempool + -- at this time and has this hash, or where it would be + InMempool !UnixTime !TxHash + | -- | in the chain's part, at this position: nothing of the mempool is in + -- the page + InChain !BlockRef + +-- | Where the page of a query starts, or 'Nothing' if it starts at a +-- transaction that is not known, which makes the page empty. +-- +-- A transaction that left the mempool unconfirmed is not known, so a page +-- that starts at one is empty. +pageStart :: DatabaseReader -> Maybe Start -> IO (Maybe From) +pageStart _ Nothing = return (Just Top) +pageStart _ (Just (AtBlock height)) = return (Just (InChain (BlockRef height maxBound))) +pageStart r (Just (AtTx h)) = + bodies r [h] <&> \found -> case (.block) <$> Map.lookup h found of + Nothing -> Nothing + Just (MemRef time) -> Just (InMempool time h) + Just position@BlockRef {} -> Just (InChain position) + +-- | Answer a query from where its page starts. +paged :: DatabaseReader -> Limits -> (From -> IO [a]) -> IO [a] +paged r limits answer = pageStart r limits.start >>= maybe (return []) answer + +-- | Run an action with, for each address, its summary and an iterator on +-- its entries in the mempool area, or 'Nothing' for an address whose +-- entries the list does not need: one that the mempool does not touch, which +-- is nearly all of them, one whose summary says that there is nothing of +-- the kind wanted, and any address when the page starts in the chain, as +-- every page after the first of a long history does. +-- +-- The summaries are read by key in one multi-get, which the filter of the +-- column family answers for the addresses that have none. No iterator is +-- moved to an address with nothing there: such a seek costs ten times a +-- read by key, and far more when it has to step over what a block just +-- deleted. +withMempoolIters :: + DatabaseReader -> + From -> + [Address] -> + (MemSummary -> Bool) -> + ([Maybe (MemSummary, Iterator)] -> IO a) -> + IO a +withMempoolIters r from as wanted action = do + summaries <- case from of + InChain _ -> return (map (const Nothing) as) + _ -> map (>>= \s -> if wanted s then Just s else Nothing) <$> M.getSummaries r as + Q.withManyIters r (mempoolAddrCF r.db) [MemAddrKeyA a | (a, Just _) <- zip as summaries] (action . pair summaries) + where + pair (Just s : rest) (it : its) = Just (s, it) : pair rest its + pair (_ : rest) its = Nothing : pair rest its + pair [] _ = [] + +-- | Transactions of an address, newest first, from where a page starts: +-- those of the mempool that belong in it, streamed from the entries of the +-- address if it has any, then those of the chain, streamed from its index. +-- Neither is read further than the page goes. +addressTxsC :: From -> Address -> Maybe Iterator -> Iterator -> ConduitT i TxRef IO () +addressTxsC from a mempool it = mapM_ (mempoolTxsC from a) mempool >> chainTxsC from a it + +-- | Transactions of an address in the chain, newest first, from where a +-- page starts, streamed from the index of the address. +chainTxsC :: From -> Address -> Iterator -> ConduitT i TxRef IO () +chainTxsC from a it = chain .| concatMapC ref + where + chain = case from of + InChain position -> matchingSkip it (AddrTxKeyA a) (AddrTxKeyB a position) + _ -> matching it (AddrTxKeyA a) + ref :: (AddrTxKey, ()) -> Maybe TxRef + ref (AddrTxKey _ t, ()) = Just t + ref _ = Nothing + +-- | Mempool transactions of an address, newest first, from where a page +-- starts. Those that entered the mempool in the same second are in the +-- order of their hashes, which is the order of their keys. +mempoolTxsC :: From -> Address -> Iterator -> ConduitT i TxRef IO () +mempoolTxsC from a it = rows .| concatMapC ref + where + rows = case from of + Top -> matching it (MemAddrTxKeyA a) + InMempool time h -> matchingSkip it (MemAddrTxKeyA a) (MemAddrTxKey a time h) + InChain _ -> return () + ref :: (MemAddrKey, MemAddrVal) -> Maybe TxRef + ref (MemAddrTxKey _ t h, _) = Just TxRef {block = MemRef t, txid = h} + ref _ = Nothing + +-- | Run an action with the stream of unspent outputs of each address, from +-- where a page starts. +-- +-- The summaries are read whatever the start of the page: the chain still +-- has, as unspent, the outputs that the mempool spends, on every page. +withUnspentStreams :: + DatabaseReader -> + From -> + [Address] -> + ([ConduitT i Unspent IO ()] -> IO a) -> + IO a +withUnspentStreams r from as action = do + summaries <- M.getSummaries r as + let fresh = case from of + InChain _ -> map (const Nothing) as + _ -> map (>>= \s -> if s.paidCount > s.bothCount then Just s else Nothing) summaries + Q.withManyIters r (mempoolAddrCF r.db) [MemAddrKeyA a | (a, Just _) <- zip as fresh] $ \mits -> + Q.withManyIters r (addrOutCF r.db) (map AddrOutKeyA as) $ \its -> + action (zipWith3 stream (zip as summaries) (pair fresh mits) its) + where + stream (a, s) = addressUnspentsC r from a s + pair (Just _ : rest) (it : its) = Just it : pair rest its + pair (_ : rest) its = Nothing : pair rest its + pair [] _ = [] + +-- | Unspent outputs of an address, newest first, from where a page starts, +-- given the summary of what the mempool does at the address, if anything, +-- and an iterator on its entries if the page has some: the outputs that the +-- mempool created and has not spent, then those of the chain that the +-- mempool does not spend, streamed from the index of the address. +-- +-- Whether the mempool spends an output is a read by key, and the summary +-- says how many of them there are to find: none for nearly every address, +-- so that nothing is read, and when the last one is found the reads stop. +addressUnspentsC :: + DatabaseReader -> + From -> + Address -> + Maybe MemSummary -> + Maybe Iterator -> + Iterator -> + ConduitT i Unspent IO () +addressUnspentsC r from a summary mempool it = do + mapM_ (\mit -> fresh mit .| concatMapC created .| hide (maybe 0 (.bothCount) summary) 1) mempool + chainUnspentsC r from a it .| hide (maybe 0 (\s -> s.spentCount - s.bothCount) summary) 1 + where + -- the outputs of the transaction that the page starts at come first + -- among those of the same second whose hashes are not smaller + fresh mit = case from of + Top -> matching mit (MemAddrOutKeyA a) + InMempool time h -> matchingSkip mit (MemAddrOutKeyA a) (MemAddrOutKey a time (OutPoint h 0)) + InChain _ -> return () + created :: (MemAddrKey, MemAddrVal) -> Maybe Unspent + created (MemAddrOutKey _ t p, MemAddrOutVal v s) = + Just Unspent {block = MemRef t, outpoint = p, value = v, script = s, address = Just a} + created _ = Nothing + -- let outputs through, but for those that the mempool spends, of which + -- there are no more than a number. They are asked about several at a + -- time, in one multi-get, which costs a fifth of asking about each: one + -- at first, then twice as many each time. A page of one address is then + -- a few reads, and the first output of each of the hundreds of + -- addresses of a wallet, which is all that a merge of them may take, + -- does not cost a batch of rows read ahead for each. + hide :: Word64 -> Int -> ConduitT Unspent Unspent IO () + hide 0 _ = awaitForever yield + hide n size = + gather size >>= \case + [] -> return () + batch -> do + found <- lift (spentAmong batch) + yieldMany [u | (u, False) <- zip batch found] + hide (n - min n (fromIntegral (length (filter id found)))) (min hideBatch (size * 2)) + -- whether the mempool spends each of some outputs of the address: a + -- read by key for each of a few, and one multi-get for more, which + -- only then costs less + spentAmong :: [Unspent] -> IO [Bool] + spentAmong batch + | length batch < 8 = forM batch $ \u -> do + found <- retrieveCF r.db (mempoolAddrCF r.db) (MemAddrSpentKey a u.outpoint) + return (isJust (found :: Maybe MemAddrVal)) + | otherwise = + map isJust <$> multiGetCF r.db (mempoolAddrCF r.db) [encode (MemAddrSpentKey a u.outpoint) | u <- batch] + gather :: Int -> ConduitT Unspent o IO [Unspent] + gather 0 = return [] + gather k = + await >>= \case + Nothing -> return [] + Just u -> (u :) <$> gather (k - 1) + +-- | The most outputs that are asked about at once when looking for those +-- that the mempool spends. More would save little, and each one is a row +-- read ahead of what a page may need. +hideBatch :: Int +hideBatch = 32 + +-- | Unspent outputs of an address in the chain, newest first, from where a +-- page starts, streamed from the index of the address. Those that the +-- mempool spends are among them. +chainUnspentsC :: DatabaseReader -> From -> Address -> Iterator -> ConduitT i Unspent IO () +chainUnspentsC r from a it = chain .| concatMapC output + where + chain = case from of + InChain position -> matchingSkip it (AddrOutKeyA a) (AddrOutKeyB a position) + _ -> matching it (AddrOutKeyA a) + output :: (AddrOutKey, OutVal) -> Maybe Unspent + output = uncurry (toUnspent r.net r.ctx) + +------------------------------------------------------------------------------- +-- Mempool +------------------------------------------------------------------------------- + +-- | The whole mempool, newest first. +getMempool :: View -> IO [(UnixTime, TxHash)] +getMempool (View r) = Q.getMempool r + +-- | Page of the mempool, newest first, from the offset and limit of the +-- t'Limits'; its start is ignored. The list of the mempool and its index by +-- time are the same in both layouts. +getMempoolPage :: View -> Limits -> IO [(UnixTime, TxHash)] +getMempoolPage (View r) = Q.getMempoolPage r + +------------------------------------------------------------------------------- +-- Extended public keys +------------------------------------------------------------------------------- + +-- | Balances of the addresses of an extended public key, derived up to the +-- exact gap (see 'scanXPubBals'), with the mempool applied. An address that +-- only the mempool has used counts as used, as it did in version 20. +xPubBals :: View -> XPubSpec -> IO [XPubBal] +xPubBals v@(View r) xpub = do + Derived ext chg <- derivedAddrs r xpub + bals <- scanXPubBals (getBalances v) r.initGap r.maxGap ext chg + Q.count r $ \s -> incrementCounter s.dataXPubBals (length bals) + return bals + +-- | Unspent outputs of an extended public key, newest first, given its +-- balances from @xPubBals@. The addresses are read in step, each only as far +-- as the page needs, as 'Q.xPubUnspents' reads them. +xPubUnspents :: View -> [XPubBal] -> Limits -> IO [XPubUnspent] +xPubUnspents (View r) xbals limits = paged r limits $ \from -> do + let quota = case (deOffset limits).limit of + 0 -> Nothing + l -> Just l + tag b = mapC (\u -> XPubUnspent {path = b.path, unspent = u}) + us <- withUnspentStreams r from (map (.balance.address) funded) $ \streams -> + runConduit $ + mergeDescGroups (.unspent.block) (unspentKey . (.unspent)) quota (zipWith (\b s -> s .| tag b) funded streams) + .| applyLimitsC limits + .| sinkList + Q.count r $ \s -> incrementCounter s.dataXPubUnspents (length us) + return us + where + funded = filter ((> 0) . (.balance.utxo)) xbals + +-- | Transactions of an extended public key, newest first, given its balances +-- from @xPubBals@. +xPubTxs :: View -> [XPubBal] -> Limits -> IO [TxRef] +xPubTxs v@(View r) xbals limits = do + txs <- getAddressesTxs v (Q.usedAddresses xbals) limits + Q.count r $ \s -> incrementCounter s.dataXPubTxs (length txs) + return txs + +-- | Number of transactions of an extended public key, given its balances +-- from @xPubBals@. +xPubTxCount :: View -> [XPubBal] -> IO Word32 +xPubTxCount v@(View r) xbals = do + Q.count r $ \s -> incrementCounter s.dataXPubTxCount 1 + getAddressesTxCount v (Q.usedAddresses xbals) + +-- | Number of distinct transactions of a set of addresses: each transaction +-- is counted once even when it touches several of them. +-- +-- Those of the chain are counted from the keys of its index, as +-- 'Q.getAddressesTxCount' counts them, and those of the mempool from the +-- summaries of the addresses: nothing more is read when none of them, or +-- only one, has transactions in the mempool, and otherwise the transactions +-- of those that have are read, to count each once. No transaction is in +-- both areas. +getAddressesTxCount :: View -> [Address] -> IO Word32 +getAddressesTxCount _ [] = return 0 +getAddressesTxCount (View r) as = do + inBlocks <- Q.getAddressesTxCount r as + inMempool <- withMempoolIters r Top as ((> 0) . (.txs)) $ \mempools -> + case [(a, m) | (a, Just m) <- zip as mempools] of + [] -> return 0 + [(_, (s, _))] -> return (fromIntegral s.txs) + several -> do + txs <- forM several $ \(a, (_, it)) -> runConduit (mempoolTxsC Top a it .| mapC (.txid) .| sinkList) + return (HashSet.size (HashSet.fromList (concat txs))) + return (inBlocks + fromIntegral inMempool) diff --git a/src/Haskoin/Store/Database/Query/Pooled.hs b/src/Haskoin/Store/Database/Query/Pooled.hs new file mode 100644 --- /dev/null +++ b/src/Haskoin/Store/Database/Query/Pooled.hs @@ -0,0 +1,518 @@ +-- | +-- Module : Haskoin.Store.Database.Query.Pooled +-- Copyright : (c) Haskoin Developers +-- License : MIT +-- Maintainer : jprupp@protonmail.ch +-- Stability : experimental +-- Portability : POSIX +-- +-- The queries of the store with a mempool that is not the store's own laid +-- over the chain: the shared pool of a fleet of stores, which +-- "Haskoin.Store.Fleet.Redis" keeps in Redis. See "A fleet that answers as +-- one" in @docs\/layered-database.md@. +-- +-- = Why another set of queries +-- +-- "Haskoin.Store.Database.Query.Layered" answers from the two areas of one +-- database, read through one snapshot. Stores that share a Redis are to +-- give the same answer to the same request, and their own mempools differ. +-- So each answers from the chain as it was at the block that the fleet +-- agreed on, which every store has the same, and from the one pool that +-- they share. The chain's part of an answer is read as the layered queries +-- read it, with the same code. The mempool's part comes through a +-- t'PoolReads', a handful of functions that say what a pool has: its +-- summaries, the entries of an address by the page, bodies, spenders and +-- its list. +-- +-- The alternative was to give the layered queries the same handful of +-- functions for the store's own mempool area. They read that area through +-- iterators that are made once for a request and moved from address to +-- address, which is where their speed comes from, and which a function +-- that returns a page would hide. The two sets share what is the same, and +-- the tests hold this one to the answers of the other: 'localPool' is the +-- store's own mempool area as a t'PoolReads', and with it every query here +-- must answer as the layered one does. +-- +-- = What a pool cannot say +-- +-- A transaction that left a mempool unconfirmed is kept by the store that +-- deleted it, and by no other. A fleet cannot answer the same about it from +-- every store, so these queries do not know deleted transactions at all: a +-- page that starts at one is empty. +module Haskoin.Store.Database.Query.Pooled + ( PoolReads (..), + pooledRead, + localPool, + pageStart, + ) +where + +import Conduit + ( ConduitT, + await, + awaitForever, + lift, + mapC, + runConduit, + sinkList, + yield, + yieldMany, + (.|), + ) +import Control.Monad (forM) +import Data.Bits ((.&.)) +import Data.ByteString qualified as BS +import Data.Functor ((<&>)) +import Data.HashMap.Strict qualified as HashMap +import Data.HashSet qualified as HashSet +import Data.IntMap.Strict qualified as IntMap +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Maybe (catMaybes, isJust) +import Data.Serialize (encode) +import Data.Word (Word16, Word32, Word64) +import Database.RocksDB (Iterator) +import Database.RocksDB.Query (matchingAsListCF, retrieveCF) +import Haskoin + ( Address, + OutPoint (..), + Tx (..), + TxHash, + TxOut (..), + eitherToMaybe, + scriptToAddressBS, + ) +import Haskoin.Store.Common + ( Limits (..), + Start (..), + StoreRead (..), + applyLimitsC, + deOffset, + mergeDescGroups, + notDeleted, + scanXPubBals, + txRefKey, + unspentKey, + ) +import Haskoin.Store.Data + ( Balance (..), + BlockRef (..), + Spender, + TxData (..), + TxRef (..), + UnixTime, + Unspent (..), + XPubBal (..), + XPubUnspent (..), + ) +import Haskoin.Store.Database.Mempool qualified as M +import Haskoin.Store.Database.Query qualified as Q +import Haskoin.Store.Database.Query.Layered (From (..), chainTxsC, chainUnspentsC, withSpenders) +import Haskoin.Store.Database.Reader + ( DatabaseReader (..), + Derived (..), + addrOutCF, + addrTxCF, + derivedAddrs, + mempoolAddrCF, + mempoolCF, + txCF, + ) +import Haskoin.Store.Database.Types + ( AddrOutKey (..), + AddrTxKey (..), + MemAddrKey (..), + MemAddrVal (..), + MemSpenderKey (..), + MemSummary (..), + TxKey (..), + decodeTxKey, + ) + +-- | What a mempool has, as much as the queries need of it. Each function +-- answers about the pool as it is when asked: one that goes with a block +-- must fail, by throwing, when the pool has moved to another. +data PoolReads = PoolReads + { -- | the summary of each address, in their order, or 'Nothing' for an + -- address that the pool does not touch + summaries :: [Address] -> IO [Maybe MemSummary], + -- | transactions of an address, newest first and in the order of their + -- hashes within a second, from the one that entered at a time with a + -- hash, or where it would be, or from the newest; at most so many + addressTxs :: Address -> Maybe (UnixTime, TxHash) -> Int -> IO [(UnixTime, TxHash)], + -- | outputs that the pool pays to an address, in the same order, from + -- one of a time or from the newest, at most so many, each with whether + -- the pool also spends it + addressOuts :: Address -> Maybe (UnixTime, OutPoint) -> Int -> IO [(Unspent, Bool)], + -- | whether the pool spends each of some outputs of an address + spentOutputs :: Address -> [OutPoint] -> IO [Bool], + -- | for each of some transactions, in their order: its body if it is + -- in the pool, without spenders, and the inputs of the pool that spend + -- its outputs, by output, whether it is in the pool or in the chain. + -- The two come together because nearly every question about a + -- transaction needs both, and a pool that is far away answers them in + -- one go. + bodies :: [TxHash] -> IO [(Maybe TxData, IntMap.IntMap Spender)], + -- | the input of the pool that spends each output, if one does + spenders :: [OutPoint] -> IO [Maybe Spender], + -- | the list of the pool, newest first and by hash downwards within a + -- second, from an offset, at most so many, or all of it for 0 + page :: Word32 -> Word32 -> IO [(UnixTime, TxHash)], + -- | the transactions of the pool whose hash starts with six bytes, as + -- 'decodeTxKey' gives them + startingWith :: (Word32, Word16) -> IO [TxHash] + } + +-- | The queries of a store that answers from the chain as a reader has it, +-- which is to be the view of the database at a block, with a pool on top. +pooledRead :: DatabaseReader -> PoolReads -> StoreRead +pooledRead r pool = + StoreRead + { net = r.net, + ctx = r.ctx, + getBestBlock = Q.getBestBlock r, + getBlocksAtHeight = Q.getBlocksAtHeight r, + getBlock = Q.getBlock r, + getTxData = \h -> only <$> getManyTxData r pool [h], + getManyTxData = getManyTxData r pool, + getSpender = getSpender r pool, + getBalance = getBalance r pool, + getUnspent = getUnspent r pool, + getMempool = pool.page 0 0, + getMempoolPage = \l -> pool.page l.offset l.limit, + getAddressesTxs = getAddressesTxs r pool, + getAddressesUnspents = getAddressesUnspents r pool, + initialGap = r.initGap, + maxGap = r.maxGap, + getNumTxData = getNumTxData r pool, + getBalances = getBalances r pool, + getAddressTxs = \a -> getAddressesTxs r pool [a], + getAddressUnspents = \a -> getAddressesUnspents r pool [a], + xPubBals = \xpub -> do + Derived ext chg <- derivedAddrs r xpub + scanXPubBals (getBalances r pool) r.initGap r.maxGap ext chg, + xPubUnspents = \_ -> xPubUnspents r pool, + xPubTxs = \_ xbals -> getAddressesTxs r pool (Q.usedAddresses xbals), + xPubTxCount = \_ xbals -> getAddressesTxCount r pool (Q.usedAddresses xbals), + getAddressesTxCount = getAddressesTxCount r pool + } + where + only = \case + [found] -> found + _ -> Nothing + +------------------------------------------------------------------------------- +-- Transactions +------------------------------------------------------------------------------- + +-- | Data of many transactions, in the order of the hashes: those of the +-- pool from it, the others from the chain, each with the spenders that +-- blocks and the pool give to its outputs. Deleted ones are not known. +getManyTxData :: DatabaseReader -> PoolReads -> [TxHash] -> IO [Maybe TxData] +getManyTxData _ _ [] = return [] +getManyTxData r pool hs = do + found <- known r pool hs + return [Map.lookup h found | h <- hs] + +-- | The data of transactions by hash: those that the pool has, and those +-- that the chain has for the others, each with the spenders that blocks +-- and the pool give to its outputs. One read of the pool, and one of the +-- chain for what the pool does not have. +known :: DatabaseReader -> PoolReads -> [TxHash] -> IO (Map TxHash TxData) +known _ _ [] = return Map.empty +known r pool hs = do + inPool <- zip hs <$> pool.bodies hs + let unconfirmed = Map.fromList [(h, td) | (h, (Just td, _)) <- inPool] + spent = HashMap.fromList [(h, spenders) | (h, (_, spenders)) <- inPool, not (IntMap.null spenders)] + rest = filter (`Map.notMember` unconfirmed) hs + chain <- case rest of + [] -> return Map.empty + _ -> do + found <- catMaybes . zipWith (fmap . (,)) rest <$> Q.retrieveManyCF r.db (txCF r.db) (map TxKey rest) + -- with the spenders that blocks give to their outputs + Map.fromList . zip (map fst found) <$> Q.withChainSpenders r found + return (Map.mapWithKey (withSpenders spent) (unconfirmed <> Map.mapMaybe notDeleted' chain)) + where + notDeleted' = notDeleted . Just + +-- | Transactions whose hash, read as a number, matches a short identifier +-- of the Blockchain.info API, in the order of their hashes. +getNumTxData :: DatabaseReader -> PoolReads -> Word64 -> IO [TxData] +getNumTxData r pool i = do + inPool <- pool.startingWith prefix + chain <- matchingAsListCF r.db (txCF r.db) (TxKeyS prefix) + let confirmed = [h | (TxKey h, td :: TxData) <- chain, not td.deleted] + found <- known r pool (filter seventh (inPool <> confirmed)) + return (Map.elems found) + where + (prefix, bits) = decodeTxKey i + seventh h = BS.index (encode h) 6 .&. 0xf8 == bits + +-- | Input that spends an output, in the pool or in a block. +getSpender :: DatabaseReader -> PoolReads -> OutPoint -> IO (Maybe Spender) +getSpender r pool p = + pool.spenders [p] >>= \case + [Just s] -> return (Just s) + _ -> Q.getChainSpender r p + +------------------------------------------------------------------------------- +-- Addresses +------------------------------------------------------------------------------- + +-- | Balance of an address, with the pool applied. +getBalance :: DatabaseReader -> PoolReads -> Address -> IO (Maybe Balance) +getBalance r pool a = M.summaryBalance a <$> Q.getBalance r a <*> (only <$> pool.summaries [a]) + where + only = \case + [s] -> s + _ -> Nothing + +-- | Balances of addresses, in the same order, with the pool applied. +getBalances :: DatabaseReader -> PoolReads -> [Address] -> IO [Balance] +getBalances _ _ [] = return [] +getBalances r pool as = zipWith apply <$> Q.getBalances r as <*> pool.summaries as + where + apply c = maybe c (M.applySummary c) + +-- | Unspent output, if it exists and neither a block nor the pool spends +-- it. +getUnspent :: DatabaseReader -> PoolReads -> OutPoint -> IO (Maybe Unspent) +getUnspent r pool p = + pool.spenders [p] >>= \case + [Just _] -> return Nothing + _ -> + Q.getUnspent r p >>= \case + Just u -> return (Just u) + Nothing -> (>>= output) . only <$> pool.bodies [p.hash] + where + only = \case + [(found, _)] -> found + _ -> Nothing + output td = case drop (fromIntegral p.index) td.tx.outputs of + o : _ -> + Just + Unspent + { block = td.block, + outpoint = p, + value = o.value, + script = o.script, + address = eitherToMaybe (scriptToAddressBS r.net r.ctx o.script) + } + [] -> Nothing + +-- | Where the page of a query starts, or 'Nothing' if it starts at a +-- transaction that neither the pool nor the chain has. +pageStart :: DatabaseReader -> PoolReads -> Maybe Start -> IO (Maybe From) +pageStart _ _ Nothing = return (Just Top) +pageStart _ _ (Just (AtBlock height)) = return (Just (InChain (BlockRef height maxBound))) +pageStart r pool (Just (AtTx h)) = + known r pool [h] <&> \found -> case (.block) <$> Map.lookup h found of + Nothing -> Nothing + Just (MemRef time) -> Just (InMempool time h) + Just position@BlockRef {} -> Just (InChain position) + +-- | Answer a query from where its page starts. +paged :: DatabaseReader -> PoolReads -> Limits -> (From -> IO [a]) -> IO [a] +paged r pool limits answer = pageStart r pool limits.start >>= maybe (return []) answer + +-- | A stream of what a function gives by the page: it is asked for a first +-- page of a size from a start, and then for more from the last item that +-- it gave, which it gives again if it still has it, for as long as it gives +-- full pages. The pages grow, so that a long list costs few reads. The +-- first is given the size of what the query is asked for, so that one read +-- is enough for a page of the API: each read of a pool that is far away +-- costs more than the rows it brings. +pages :: (Eq k) => (x -> k) -> (Maybe k -> Int -> IO [x]) -> Int -> Maybe k -> ConduitT i x IO () +pages key fetch first = go first Nothing + where + go size after start = do + rows <- lift (fetch start size) + let fresh = maybe rows (\k -> dropWhile ((== k) . key) rows) after + yieldMany fresh + case reverse rows of + final : _ | length rows == size -> go (min 4096 (size * 4)) (Just (key final)) (Just (key final)) + _ -> return () + +-- | The transactions of an address in the pool that belong in a list that +-- starts somewhere, newest first, read so many at first: none when the +-- list starts in the chain, or when the pool is known to have nothing for +-- the address. +poolTxsC :: PoolReads -> From -> Int -> Address -> Bool -> ConduitT i TxRef IO () +poolTxsC pool from first a touched = case (from, touched) of + (InChain _, _) -> return () + (_, False) -> return () + (Top, True) -> stream Nothing + (InMempool time h, True) -> stream (Just (time, h)) + where + stream start = pages id (pool.addressTxs a) first start .| mapC (\(t, h) -> TxRef {block = MemRef t, txid = h}) + +-- | How many items to ask a pool for at first, for a query with limits: as +-- many as the page and what is skipped before it, and one more, so that a +-- page that is not full is known to be the end; within bounds, for a query +-- without a limit. +firstPage :: Limits -> Int +firstPage limits = case limits.limit of + 0 -> 256 + n -> max 16 (min 1024 (fromIntegral (n + limits.offset) + 1)) + +-- | Whether a pool may have transactions of each of some addresses, for a +-- list that starts somewhere. For one address it is not asked: its +-- transactions are, which says as much in the same read. For several, the +-- summaries are read, in one read for all of them, so that only those that +-- have something are asked for it. +touchedBy :: PoolReads -> From -> [Address] -> IO [Bool] +touchedBy pool from as = case (from, as) of + (InChain _, _) -> return (map (const False) as) + (_, [_]) -> return [True] + _ -> map isJust <$> pool.summaries as + +-- | Transactions of any of the addresses, newest first, each once. +getAddressesTxs :: DatabaseReader -> PoolReads -> [Address] -> Limits -> IO [TxRef] +getAddressesTxs _ _ [] _ = return [] +getAddressesTxs r pool as limits = paged r pool limits $ \from -> do + touched <- touchedBy pool from as + Q.withManyIters r (addrTxCF r.db) (map AddrTxKeyA as) $ \its -> + Q.joinConduits txRefKey (zipWith3 (stream from) as touched its) limits + where + stream from a t it = poolTxsC pool from (firstPage limits) a t >> chainTxsC from a it + +-- | The stream of unspent outputs of each address, from where a page +-- starts, given the iterators on the chain's index: the outputs that the +-- pool pays and does not spend, then those of the chain that the pool does +-- not spend. The pool is asked which outputs of the chain it spends +-- several at a time, four at first and then four times as many each time, +-- so that the first output of each of many addresses does not cost a batch +-- of rows read ahead, and no more once as many were found as its summary +-- counts. +unspentStreams :: + DatabaseReader -> + PoolReads -> + From -> + Limits -> + [Address] -> + IO ([Iterator] -> [ConduitT () Unspent IO ()]) +unspentStreams r pool from limits as = do + sums <- pool.summaries as + return $ \its -> zipWith3 stream as sums its + where + stream a summary it = fresh a summary >> (chainUnspentsC r from a it .| hide a (maybe 0 hidden summary) 4) + hidden s = s.spentCount - s.bothCount + fresh a = \case + Just s | s.paidCount > s.bothCount -> case from of + Top -> outs a Nothing + InMempool time h -> outs a (Just (time, OutPoint h 0)) + InChain _ -> return () + _ -> return () + -- some of what the pool pays it also spends, so more is asked for + outs a start = + pages (\(u, _) -> position u) (pool.addressOuts a) (2 * firstPage limits) start + .| awaitForever (\(u, spent) -> if spent then return () else yield u) + position u = case u.block of + MemRef t -> (t, u.outpoint) + BlockRef {} -> (0, u.outpoint) + hide :: Address -> Word64 -> Int -> ConduitT Unspent Unspent IO () + hide _ 0 _ = awaitForever yield + hide a n size = do + batch <- gather size + case batch of + [] -> return () + _ -> do + flags <- lift (pool.spentOutputs a (map (.outpoint) batch)) + yieldMany [u | (u, False) <- zip batch flags] + hide a (n - min n (fromIntegral (length (filter id flags)))) (min 256 (size * 4)) + gather :: Int -> ConduitT Unspent o IO [Unspent] + gather 0 = return [] + gather k = + await >>= \case + Nothing -> return [] + Just u -> (u :) <$> gather (k - 1) + +-- | Unspent outputs of any of the addresses, newest first. +getAddressesUnspents :: DatabaseReader -> PoolReads -> [Address] -> Limits -> IO [Unspent] +getAddressesUnspents _ _ [] _ = return [] +getAddressesUnspents r pool as limits = paged r pool limits $ \from -> do + streams <- unspentStreams r pool from limits as + Q.withManyIters r (addrOutCF r.db) (map AddrOutKeyA as) $ \its -> + Q.joinConduits unspentKey (streams its) limits + +-- | Unspent outputs of an extended public key, newest first, given its +-- balances. +xPubUnspents :: DatabaseReader -> PoolReads -> [XPubBal] -> Limits -> IO [XPubUnspent] +xPubUnspents r pool xbals limits = paged r pool limits $ \from -> do + let quota = case (deOffset limits).limit of + 0 -> Nothing + l -> Just l + tag b = mapC (\u -> XPubUnspent {path = b.path, unspent = u}) + streams <- unspentStreams r pool from limits (map (.balance.address) funded) + Q.withManyIters r (addrOutCF r.db) (map (AddrOutKeyA . (.balance.address)) funded) $ \its -> + runConduit $ + mergeDescGroups + (.unspent.block) + (unspentKey . (.unspent)) + quota + (zipWith (\b s -> s .| tag b) funded (streams its)) + .| applyLimitsC limits + .| sinkList + where + funded = filter ((> 0) . (.balance.utxo)) xbals + +-- | Number of distinct transactions of a set of addresses: those of the +-- chain, and those of the pool, read only when more than one of the +-- addresses has some there. +getAddressesTxCount :: DatabaseReader -> PoolReads -> [Address] -> IO Word32 +getAddressesTxCount _ _ [] = return 0 +getAddressesTxCount r pool as = do + inBlocks <- Q.getAddressesTxCount r as + sums <- pool.summaries as + inPool <- case [(a, s) | (a, Just s) <- zip as sums, s.txs > 0] of + [] -> return 0 + [(_, s)] -> return (fromIntegral s.txs) + several -> do + txs <- forM several $ \(a, _) -> runConduit (poolTxsC pool Top 256 a True .| mapC (.txid) .| sinkList) + return (HashSet.size (HashSet.fromList (concat txs))) + return (inBlocks + fromIntegral inPool) + +------------------------------------------------------------------------------- +-- The store's own mempool area as a pool +------------------------------------------------------------------------------- + +-- | The mempool area of a database, as a reader has it, as a pool. The +-- queries of this module with it must answer as those of +-- "Haskoin.Store.Database.Query.Layered" do, but for deleted transactions: +-- that is what the tests check, and what this is for. +localPool :: DatabaseReader -> PoolReads +localPool r = + PoolReads + { summaries = M.getSummaries r, + addressTxs = \a start n -> do + rows <- entries a + let listed = [(t, h) | (MemAddrTxKey _ t h, _) <- rows] + from (t, h) = dropWhile (\(t', h') -> t' > t || (t' == t && h' < h)) listed + return (take n (maybe listed from start)), + addressOuts = \a start n -> do + rows <- entries a + let spent = HashSet.fromList [p | (MemAddrSpentKey _ p, _) <- rows] + made t p v s = Unspent {block = MemRef t, outpoint = p, value = v, script = s, address = Just a} + listed = [(made t p v s, HashSet.member p spent) | (MemAddrOutKey _ t p, MemAddrOutVal v s) <- rows] + place (u, _) = case u.block of + MemRef t -> (t, encode u.outpoint) + BlockRef {} -> (0, encode u.outpoint) + from (t, p) = dropWhile (\x -> let (t', p') = place x in t' > t || (t' == t && p' < encode p)) listed + return (take n (maybe listed from start)), + spentOutputs = \a ps -> + forM ps $ \p -> + isJust <$> (retrieveCF r.db (mempoolAddrCF r.db) (MemAddrSpentKey a p) :: IO (Maybe MemAddrVal)), + bodies = \hs -> case hs of + [] -> return [] + _ -> zip <$> Q.retrieveManyCF r.db (mempoolCF r.db) (map TxKey hs) <*> mapM (M.getMempoolSpenders r) hs, + spenders = \ps -> case ps of + [] -> return [] + _ -> Q.retrieveManyCF r.db (mempoolCF r.db) (map MemSpenderKey ps), + page = \offset limit -> Q.getMempoolPage r Limits {limit = limit, offset = offset, start = Nothing}, + startingWith = \prefix -> do + rows <- matchingAsListCF r.db (mempoolCF r.db) (TxKeyS prefix) + return [h | (TxKey h, _ :: TxData) <- rows] + } + where + entries :: Address -> IO [(MemAddrKey, MemAddrVal)] + entries a = matchingAsListCF r.db (mempoolAddrCF r.db) (MemAddrKeyA a) 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,13 +1,4 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ImportQualifiedPost #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedRecordDot #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE NoFieldSelectors #-} -- | -- Module : Haskoin.Store.Database.Reader @@ -17,15 +8,15 @@ -- Stability : experimental -- Portability : POSIX -- --- Queries against the RocksDB database of the store. --- --- 'DatabaseReaderT' implements 'StoreReadBase' and 'StoreReadExtra' by reading --- the indices directly from RocksDB. The database is opened with --- 'withDatabaseReader', which also creates or migrates it. +-- The RocksDB database of the store: opening it ('withDatabaseReader'), which +-- also creates or migrates it, its column families, its metrics, and the +-- memo of the addresses of extended public keys. The queries are in +-- "Haskoin.Store.Database.Query". -- -- Data is split across column families by kind; see 'addrTxCF' and the other -- column family accessors. The keys stored in each are described in -- "Haskoin.Store.Database.Types". +-- -- = Why column families -- -- Each kind of record lives in its own column family. Their keys and access @@ -43,40 +34,34 @@ module Haskoin.Store.Database.Reader ( -- * RocksDB Database Access DatabaseReader (..), - DatabaseReaderT, - DataMetrics, - withDB, + DataMetrics (..), + Derived (..), + derivedAddrs, createDataMetrics, withDatabaseReader, + withLayeredReader, + initRocksDB, memoryReport, addrTxCF, addrOutCF, txCF, + spenderCF, unspentCF, blockCF, heightCF, balanceCF, mempoolCF, - getMempoolBefore, + mempoolAddrCF, mempoolInsertOps, ) where -import Conduit -import Control.Monad (forM, forM_, replicateM, (>=>)) -import Control.Monad.Reader -import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) -import Data.Bits ((.&.)) -import Data.ByteString qualified as BS +import Control.Monad (forM) import Data.ByteString.Char8 qualified as BS8 import Data.Default (def) import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict qualified as HashMap -import Data.IntMap.Strict qualified as IntMap -import Data.Functor ((<&>)) -import Data.Map.Strict qualified as Map -import Data.Maybe (catMaybes, fromMaybe, isJust, mapMaybe) -import Data.Serialize (Serialize, decode, encode) +import Data.Maybe (fromMaybe, isJust, mapMaybe) import Data.Text (Text) import Data.Text qualified as T import Data.Word (Word32) @@ -90,9 +75,6 @@ import Text.Read (readMaybe) import UnliftIO --- | Monad transformer to query the database. -type DatabaseReaderT = ReaderT DatabaseReader - -- | Open database and its settings. data DatabaseReader = DatabaseReader { -- | RocksDB handle, with the column families of the store @@ -131,18 +113,18 @@ derivedCacheSize = 512 -- | Addresses of an xpub, from the cache or a new lazy derivation. -derivedAddrs :: (MonadIO m) => XPubSpec -> DatabaseReaderT m Derived -derivedAddrs xpub = do - ref <- asks (.derived) - ctx <- asks (.ctx) - let fresh = +derivedAddrs :: DatabaseReader -> XPubSpec -> IO Derived +derivedAddrs r xpub = do + let ref = r.derived + ctx = r.ctx + fresh = let addrs m = deriveAddresses (deriveFunction ctx xpub.deriv) (pubSubKey ctx xpub.key m) 0 in Derived (addrs 0) (addrs 1) - liftIO . atomicModifyIORef' ref $ \c -> + atomicModifyIORef' ref $ \c -> case HashMap.lookup xpub c.newer of Just d -> (c, d) Nothing -> @@ -200,23 +182,23 @@ where n = 10 --- | Run an action with the metrics, if they are enabled. -withMetrics :: (MonadReader DatabaseReader m) => (DataMetrics -> m a) -> m () -withMetrics go = asks (.metrics) >>= mapM_ go - --- | Version of the database layout. Databases of versions 18 and 19 are --- migrated when opened; other versions are refused. +-- | Version of the layout that 'withDatabaseReader' opens, in which the +-- mempool is written into the indices of the chain. Databases of versions +-- 18 and 19 are migrated to it when opened that way; other versions are +-- refused. -- +-- The store runs on a later one, +-- 'Haskoin.Store.Database.Migrate.currentVersion', and opens its database +-- with 'withLayeredReader' and 'Haskoin.Store.Database.Migrate.upgradeDatabase'. +-- This version is kept for the tests, which hold the new layout to the +-- answers of this one, and as the way through for databases of 18 and 19. +-- -- Bumping the version is how a change to the database layout is made safe: an -- old database is either migrated in place when it is opened or refused, never -- read with the wrong layout. dataVersion :: Word32 dataVersion = 20 --- | Run a query against a database. -withDB :: DatabaseReader -> DatabaseReaderT m a -> m a -withDB = flip runReaderT - -- | Open the database and run a query against it. Creates the database and its -- column families if missing, and migrates it from older versions. -- @@ -226,7 +208,6 @@ -- families are flushed, block cache size in bytes, and metrics. 'Nothing' leaves -- a setting to RocksDB. withDatabaseReader :: - (MonadUnliftIO m) => Network -> Ctx -> Word32 -> @@ -238,24 +219,76 @@ Maybe Int -> Maybe Int -> Maybe DataMetrics -> - DatabaseReaderT m a -> - m a -withDatabaseReader net ctx igap gap dir bloom maxOpenFiles writeBuffers maxWal blockCache stats m = - withRunInIO $ \run -> - withDBCF dir cfg (columnFamilyConfig bloom (isJust blockCache)) $ \db -> do - derived <- newIORef (DerivedCache HashMap.empty HashMap.empty) - let bdb = - DatabaseReader - { db = db, - maxGap = gap, - net = net, - initGap = igap, - metrics = stats, - ctx = ctx, - derived = derived - } - initRocksDB bdb - run $ runReaderT m bdb + (DatabaseReader -> IO a) -> + IO a +withDatabaseReader = withReader columnFamilyConfig initRocksDB + +-- | Open a database with the column families of the layered layout of +-- @docs\/layered-database.md@: those of 'withDatabaseReader' and one more, +-- for what the mempool does at each address. The arguments are those of +-- 'withDatabaseReader'. +-- +-- It neither checks nor sets the version of the database: +-- 'Haskoin.Store.Database.Migrate.upgradeDatabase' does, and has to be +-- called before anything reads the database. The store opens its database +-- with the two. +-- +-- Opening a database this way adds the column family to it. RocksDB only +-- opens a database when given all its column families, so a store that does +-- not know this one, such as any through 'withDatabaseReader', can no +-- longer open the database afterwards. That is the point of no return of +-- the migration. +withLayeredReader :: + Network -> + Ctx -> + Word32 -> + Word32 -> + FilePath -> + Bool -> + Maybe Int -> + Maybe Int -> + Maybe Int -> + Maybe Int -> + Maybe DataMetrics -> + (DatabaseReader -> IO a) -> + IO a +withLayeredReader = withReader layeredFamilyConfig (\_ -> return ()) + +-- | Open a database with these column families, given whether to use Bloom +-- filters and whether there is a shared block cache, and run a check on it +-- before anything else. The other arguments are those of +-- 'withDatabaseReader'. +withReader :: + (Bool -> Bool -> [(String, Config)]) -> + (DatabaseReader -> IO ()) -> + Network -> + Ctx -> + Word32 -> + Word32 -> + FilePath -> + Bool -> + Maybe Int -> + Maybe Int -> + Maybe Int -> + Maybe Int -> + Maybe DataMetrics -> + (DatabaseReader -> IO a) -> + IO a +withReader families check net ctx igap gap dir bloom maxOpenFiles writeBuffers maxWal blockCache stats m = + withDBCF dir cfg (families bloom (isJust blockCache)) $ \db -> do + derived <- newIORef (DerivedCache HashMap.empty HashMap.empty) + let bdb = + DatabaseReader + { db = db, + maxGap = gap, + net = net, + initGap = igap, + metrics = stats, + ctx = ctx, + derived = derived + } + check bdb + m bdb where cfg = def @@ -284,7 +317,11 @@ <> T.justifyRight 16 ' ' (num mem) <> T.justifyRight 16 ' ' (num readers) return . T.unlines $ - ["** RocksDB memory (bytes) **", T.justifyLeft 10 ' ' "family" <> T.justifyRight 16 ' ' "memtables" <> T.justifyRight 16 ' ' "table readers"] + [ "** RocksDB memory (bytes) **", + T.justifyLeft 10 ' ' "family" + <> T.justifyRight 16 ' ' "memtables" + <> T.justifyRight 16 ' ' "table readers" + ] <> map line rows <> [ line ("total", Just (total (\(_, m, _) -> m)), Just (total (\(_, _, r) -> r))), "block cache: " <> num cache, @@ -302,12 +339,31 @@ -- | Column families, with Bloom filters or not, and with their index and -- filter blocks in the block cache or not. +-- +-- = Why the indices by address never have filters +-- +-- A filter lets RocksDB skip a table file that cannot have a key, or, for a +-- scan, a key prefix. That is safe for column families that are read by +-- key. It is not for the two that are scanned by address, as long as the +-- iterators of the binding have no bound: a scan asks RocksDB for the first +-- key at or after an address and stops when the key is of another address. +-- With filters, the files that hold the keys of the addresses that follow +-- are skipped, as they should be, but the keys that were deleted lately are +-- not in a file yet, and RocksDB steps over every one of them looking for a +-- key to give back, since it can no longer see that most still have +-- neighbours that are alive. +-- +-- Measured with 5,000 mempool transactions just deleted: a scan of an +-- address that has nothing took 810 microseconds with filters on these +-- indices, and 13 without, in the layout of version 20. No filter was ever +-- built before rocksdb-haskell-jprupp 2.6.2, so it never happened to a +-- store, and filters are on by default now for everything else. columnFamilyConfig :: Bool -> Bool -> [(String, Config)] columnFamilyConfig bloom cached = - [ ("addr-tx", c (Just 22)), - ("addr-out", c (Just 22)), + [ ("addr-tx", scanned (Just 22)), + ("addr-out", scanned (Just 22)), ("tx", c (Just 33)), - ("spender", c (Just 33)), -- unused + ("spender", c (Just 33)), ("unspent", c (Just 37)), ("block", c (Just 33)), ("height", c Nothing), @@ -316,7 +372,41 @@ ] where c p = def {prefixLength = p, bloomFilter = bloom, cacheIndexAndFilterBlocks = cached} + scanned p = (c p) {bloomFilter = False} +-- | Column families of the layered layout: those of 'columnFamilyConfig', +-- and one for the entries of the mempool by address ('MemAddrKey'). +-- +-- The two column families of the mempool always have Bloom filters, whatever +-- the setting for the others. Almost every lookup in them is for something +-- that is not there: a confirmed transaction, an output that no mempool +-- transaction spends, an address with nothing in the mempool. A filter +-- answers those without reading a block, and for column families this small +-- it takes a few megabytes; on the column families of the chain the same +-- filters would take gigabytes, which is why they are optional there. +-- +-- The entries by address are in a column family of their own because their +-- filter is on the first 22 bytes of the key, the kind of key and the +-- address: a scan of an address with nothing in the mempool then stops at +-- the filter. The mempool column family is read by whole keys and scanned +-- across prefixes, for the index by time, so it cannot have a filter by +-- prefix. +-- +-- That scan through a filter is what 'columnFamilyConfig' keeps out of the +-- indices of the chain, and it is as slow here after a block, which deletes +-- the keys of the transactions it confirms: 1.6 milliseconds for an address +-- with nothing, measured. It is one of the things that have to change before +-- this layout is used; @docs\/layered-database.md@ says how. +layeredFamilyConfig :: Bool -> Bool -> [(String, Config)] +layeredFamilyConfig bloom cached = + map mempool (columnFamilyConfig bloom cached) + <> [("mempool-addr", c (Just 22))] + where + c p = def {prefixLength = p, bloomFilter = True, cacheIndexAndFilterBlocks = cached} + mempool (name, cfg) + | name == "mempool" = (name, c Nothing) + | otherwise = (name, cfg) + -- | Column family for transactions by address ('AddrTxKey'). addrTxCF :: DB -> ColumnFamily addrTxCF db = columnFamilies db !! 0 @@ -333,6 +423,11 @@ unspentCF :: DB -> ColumnFamily unspentCF db = columnFamilies db !! 4 +-- | Column family for the inputs of blocks that spend outputs +-- as t'Haskoin.Store.Database.Types.SpenderKey' says. +spenderCF :: DB -> ColumnFamily +spenderCF db = columnFamilies db !! 3 + -- | Column family for blocks ('BlockKey'). blockCF :: DB -> ColumnFamily blockCF db = columnFamilies db !! 5 @@ -346,9 +441,16 @@ balanceCF db = columnFamilies db !! 7 -- | Column family for mempool transactions ('MemTxKey' and 'MemTimeKey'). +-- In the layered layout it also has their bodies, under t'TxKey', and +-- their spenders, under t'MemSpenderKey'. mempoolCF :: DB -> ColumnFamily mempoolCF db = columnFamilies db !! 8 +-- | Column family for what the mempool does at each address ('MemAddrKey'). +-- Only a database opened with 'withLayeredReader' has it. +mempoolAddrCF :: DB -> ColumnFamily +mempoolAddrCF db = columnFamilies db !! 9 + -- | Set the version of a new database, migrate an old one, or call 'error' if the version is not supported. initRocksDB :: DatabaseReader -> IO () initRocksDB DatabaseReader {db = db} = @@ -388,439 +490,6 @@ insertOpCF (mempoolCF db) (MemTimeKey t h) () ] --- | Mempool from the index by time, newest first. The index sorts last in --- the mempool column family, so seek past its prefix and walk backwards --- until a key is no longer in it. -mempoolNewestC :: Iterator -> ConduitT i (UnixTime, TxHash) IO () -mempoolNewestC it = do - liftIO $ do - -- 0x0c is the first prefix after the 0x0b of 'MemTimeKey' - iterSeek it (BS.singleton 0x0c) - iterValid it >>= \case - True -> iterPrev it - False -> iterLast it - go - where - go = - liftIO (iterKey it) >>= \case - Just k | Right (MemTimeKey t h) <- decode k -> do - yield (t, h) - liftIO (iterPrev it) - go - _ -> return () - --- | Mempool transactions that entered it before the given time, oldest --- first, at most as many as given. Reads only those entries of the index. -getMempoolBefore :: - (MonadIO m) => - UnixTime -> - Int -> - DatabaseReaderT m [(UnixTime, TxHash)] -getMempoolBefore time n = do - db <- asks (.db) - liftIO . withIterCF db (mempoolCF db) $ \it -> - runConduit $ - matching it MemTimeKeyS - .| concatMapC entry - .| takeWhileC ((< time) . fst) - .| takeC n - .| sinkList - where - entry (MemTimeKey t h, ()) = Just (t, h) - entry (MemTimeKeyS, ()) = Nothing - -- | Set the version of a new database. setInitRocksDB :: DB -> IO () setInitRocksDB db = insert db VersionKey dataVersion - --- | Stream the transactions of an address, newest first, from a starting point. --- If the start is a transaction that is not found, nothing is streamed. -addressConduit :: - (MonadIO m) => - Address -> - Maybe Start -> - Iterator -> - ConduitT i TxRef (DatabaseReaderT m) () -addressConduit a s it = do - pipe .| mapC (uncurry f) - where - f (AddrTxKey _ t) () = t - f _ _ = undefined - pipe = case s of - Nothing -> - readerC $ \_ -> - transPipe liftIO $ - matching it (AddrTxKeyA a) - Just (AtBlock bh) -> - readerC $ \_ -> - transPipe liftIO $ - matchingSkip - it - (AddrTxKeyA a) - (AddrTxKeyB a (BlockRef bh maxBound)) - Just (AtTx txh) -> - lift (getTxData txh) >>= \case - Just TxData {block = b@BlockRef {}} -> - readerC $ \_ -> - transPipe liftIO $ - matchingSkip - it - (AddrTxKeyA a) - (AddrTxKeyB a b) - Just TxData {block = MemRef {}} -> - let cond (AddrTxKey _ (TxRef MemRef {} th)) = th /= txh - cond (AddrTxKey _ (TxRef BlockRef {} _)) = False - cond _ = undefined - in readerC $ \_ -> - transPipe liftIO $ - matching it (AddrTxKeyA a) - .| (dropWhileC (cond . fst) >> mapC id) - Nothing -> return () - --- | Stream the unspent outputs of an address, newest first, from a starting --- point. If the start is a transaction that is not found, nothing is streamed. -unspentConduit :: - (MonadIO m) => - Network -> - Ctx -> - Address -> - Maybe Start -> - Iterator -> - ConduitT i Unspent (DatabaseReaderT m) () -unspentConduit net ctx a s it = - x .| mapC (uncurry (toUnspent net ctx)) .| concatC - where - x = case s of - Nothing -> - readerC $ \_ -> transPipe liftIO $ matching it (AddrOutKeyA a) - Just (AtBlock h) -> - readerC $ \_ -> - transPipe liftIO $ - matchingSkip - it - (AddrOutKeyA a) - (AddrOutKeyB a (BlockRef h maxBound)) - Just (AtTx txh) -> - lift (getTxData txh) >>= \case - Just TxData {block = b@BlockRef {}} -> - readerC $ \_ -> - transPipe liftIO $ - matchingSkip it (AddrOutKeyA a) (AddrOutKeyB a b) - Just TxData {block = MemRef {}} -> - let cond (AddrOutKey _ MemRef {} p) = p.hash /= txh - cond (AddrOutKey _ BlockRef {} _) = False - cond _ = undefined - in readerC $ \_ -> - transPipe liftIO $ - matching it (AddrOutKeyA a) - .| (dropWhileC (cond . fst) >> mapC id) - Nothing -> return () - --- | Run an action with an iterator on a column family, counting it in the metrics. -withIterCFStat :: - (MonadUnliftIO m) => - DB -> - ColumnFamily -> - (Iterator -> DatabaseReaderT m a) -> - DatabaseReaderT m a -withIterCFStat db cf f = do - m <- asks (.metrics) - bracket_ (open m) (close m) go - where - open (Just m) = incrementGauge m.dataIters 1 - open Nothing = return () - close (Just m) = decrementGauge m.dataIters 1 - close Nothing = return () - go = withRunInIO $ \run -> - withIterCF db cf $ \it -> run (f it) - --- | Run an action with this many iterators on a column family. They are --- opened and closed in a single bracket rather than one bracket each: each --- bracket leaves a frame on the stack, and every call into RocksDB through --- an iterator walks the stack, so with one bracket per address an xpub of a --- hundred addresses made each step of each iterator a hundred times slower. -withManyIters :: - (MonadUnliftIO m) => - DB -> - ColumnFamily -> - Int -> - ([Iterator] -> DatabaseReaderT m a) -> - DatabaseReaderT m a -withManyIters db cf i f = do - m <- asks (.metrics) - bracket_ (gauge m i) (gauge m (negate i)) $ - withRunInIO $ \run -> - bracket (newIORef []) (readIORef >=> mapM_ destroyIterator) $ \ref -> do - its <- replicateM i . mask_ $ do - it <- createIterator db (Just cf) - modifyIORef' ref (it :) - return it - run (f its) - where - gauge (Just m) n = incrementGauge m.dataIters n - gauge Nothing _ = return () - --- | Values of many keys of a column family, read with one multi-get, in --- the order of the keys. -retrieveManyCF :: - (KeyValue key value, Serialize key, Serialize value) => - DB -> - ColumnFamily -> - [key] -> - IO [Maybe value] -retrieveManyCF db cf keys = - map (fmap (either error id . decode)) <$> multiGetCF db cf (map encode keys) - --- | Merge streams sorted newest first, drop duplicates, and apply the offset and --- limit. -joinConduits :: - (Monad m, Ord o) => - [ConduitT () o m ()] -> - Limits -> - m [o] -joinConduits cs l = - runConduit $ joinDescStreams cs .| applyLimitsC l .| sinkList - -instance (MonadIO m) => StoreReadBase (DatabaseReaderT m) where - getCtx = asks (.ctx) - getNetwork = asks (.net) - - getTxData th = do - db <- asks (.db) - liftIO (retrieveCF db (txCF db) (TxKey th)) >>= \case - Nothing -> return Nothing - Just t -> do - withMetrics $ \s -> incrementCounter s.dataTxCount 1 - return (Just t) - - getManyTxData ths = do - db <- asks (.db) - tds <- liftIO (retrieveManyCF db (txCF db) (map TxKey ths)) - withMetrics $ \s -> incrementCounter s.dataTxCount (length (catMaybes tds)) - return tds - - getSpender op = runMaybeT $ do - td <- MaybeT $ getTxData op.hash - let i = fromIntegral op.index - MaybeT . return $ i `IntMap.lookup` td.spenders - - getUnspent p = do - db <- asks (.db) - net <- asks (.net) - ctx <- asks (.ctx) - val <- liftIO (retrieveCF db (unspentCF db) (UnspentKey p)) - case fmap (valToUnspent net ctx p) val of - Nothing -> return Nothing - Just u -> do - withMetrics $ \s -> incrementCounter s.dataUnspentCount 1 - return (Just u) - - getBalance a = do - db <- asks (.db) - withMetrics $ \s -> incrementCounter s.dataBalanceCount 1 - fmap (valToBalance a) <$> liftIO (retrieveCF db (balanceCF db) (BalKey a)) - - getMempool = getMempoolPage def - - getMempoolPage limits = do - db <- asks (.db) - withMetrics $ \s -> incrementCounter s.dataMempoolCount 1 - liftIO . withIterCF db (mempoolCF db) $ \it -> - runConduit $ - mempoolNewestC it - .| applyLimitsC limits - .| sinkList - - getBestBlock = do - withMetrics $ \s -> incrementCounter s.dataBestCount 1 - asks (.db) >>= liftIO . (`retrieve` BestKey) - - getBlocksAtHeight h = do - db <- asks (.db) - liftIO (retrieveCF db (heightCF db) (HeightKey h)) >>= \case - Nothing -> return [] - Just ls -> do - withMetrics $ \s -> incrementCounter s.dataBlockCount (length ls) - return ls - - getBlock h = do - db <- asks (.db) - liftIO (retrieveCF db (blockCF db) (BlockKey h)) >>= \case - Nothing -> return Nothing - Just b -> do - withMetrics $ \s -> incrementCounter s.dataBlockCount 1 - return (Just b) - -instance (MonadUnliftIO m) => StoreReadExtra (DatabaseReaderT m) where - getAddressesTxs addrs limits = do - db <- asks (.db) - withManyIters db (addrTxCF db) (length addrs) $ \its -> do - txs <- joinConduits (cs its) limits - withMetrics $ \s -> incrementCounter s.dataAddrTxCount (length txs) - return txs - where - cs = zipWith c addrs - c a = addressConduit a limits.start - - getAddressesUnspents addrs limits = do - db <- asks (.db) - net <- asks (.net) - ctx <- asks (.ctx) - withManyIters db (addrOutCF db) (length addrs) $ \its -> do - uns <- joinConduits (cs net ctx its) limits - withMetrics $ \s -> incrementCounter s.dataUnspentCount (length uns) - return uns - where - cs net ctx = zipWith (c net ctx) addrs - c net ctx a = unspentConduit net ctx a limits.start - - getAddressUnspents a limits = do - db <- asks (.db) - net <- asks (.net) - ctx <- asks (.ctx) - us <- withIterCFStat db (addrOutCF db) $ \it -> - runConduit $ - unspentConduit net ctx a limits.start it - .| applyLimitsC limits - .| sinkList - withMetrics $ \s -> incrementCounter s.dataUnspentCount (length us) - return us - - getAddressTxs a limits = do - db <- asks (.db) - txs <- withIterCFStat db (addrTxCF db) $ \it -> - runConduit $ - addressConduit a limits.start it - .| applyLimitsC limits - .| sinkList - withMetrics $ \s -> incrementCounter s.dataAddrTxCount (length txs) - return txs - - getMaxGap = asks (.maxGap) - - getInitialGap = asks (.initGap) - - getNumTxData i = ReaderT $ \r -> do - let (sk, w) = decodeTxKey i - ls <- liftIO $ matchingAsListCF r.db (txCF r.db) (TxKeyS sk) - let f t = - let bs = encode $ txHash t.tx - b = BS.head (BS.drop 6 bs) - w' = b .&. 0xf8 - in w == w' - txs = filter f $ map snd ls - forM_ r.metrics $ \s -> incrementCounter s.dataTxCount (length txs) - return txs - - getBalances [] = return [] - getBalances as = do - db <- asks (.db) - withMetrics $ \s -> incrementCounter s.dataBalanceCount (length as) - vals <- liftIO (retrieveManyCF db (balanceCF db) (map BalKey as)) - return (zipWith f as vals) - where - f a Nothing = zeroBalance a - f a (Just v) = valToBalance a v - - xPubBals xpub = do - igap <- asks (.initGap) - gap <- asks (.maxGap) - Derived ext chg <- derivedAddrs xpub - ext1 <- derive_until_gap gap 0 (take (fromIntegral igap) ext) - if all nullxb ext1 - then do - withMetrics $ \s -> incrementCounter s.dataXPubBals (length ext1) - return ext1 - else do - ext2 <- derive_until_gap gap 0 (drop (fromIntegral igap) ext) - chg' <- derive_until_gap gap 1 chg - let bals = ext1 <> ext2 <> chg' - withMetrics $ \s -> incrementCounter s.dataXPubBals (length bals) - return bals - where - nullxb b = nullBalance b.balance - derive_until_gap gap m adrs = - let xb b n = XPubBal {path = [m, n], balance = b} - ig = fromIntegral gap - test acc = - let ns = takeWhile nullxb acc - in length ns > ig - go acc [] = return $ reverse acc - go acc as - | test acc = - let (ns, ys) = span nullxb acc - xs = take ig $ reverse ns - in return $ reverse ys <> xs - | otherwise = do - let (as', as'') = splitAt ig as - bs <- getBalances (map snd as') - let xs = reverse $ zipWith xb bs (map fst as') - go (xs <> acc) as'' - in go [] adrs - - -- The first unspent outputs of each address, at most offset plus limit - -- of them, sorted together. Read the addresses in step, so that each is - -- read only as far as the page needs, rather than decoding the whole - -- quota of every address to keep one page of it. - xPubUnspents _xspec xbals limits = do - db <- asks (.db) - net <- asks (.net) - ctx <- asks (.ctx) - let quota = case (deOffset limits).limit of - 0 -> Nothing - l -> Just l - stream b it = - unspentConduit net ctx b.balance.address limits.start it - .| mapC (\u -> XPubUnspent {path = b.path, unspent = u}) - us <- withManyIters db (addrOutCF db) (length cs) $ \its -> - runConduit $ - mergeDescGroups (.unspent.block) quota (zipWith stream cs its) - .| applyLimitsC limits - .| sinkList - withMetrics $ \s -> incrementCounter s.dataXPubUnspents (length us) - return us - where - cs = filter ((> 0) . (.balance.utxo)) xbals - - xPubTxs _xspec xbals limits = do - let as = - map (.address) $ - filter (not . nullBalance) $ - map (.balance) xbals - txs <- getAddressesTxs as limits - withMetrics $ \s -> incrementCounter s.dataXPubTxs (length txs) - return txs - - -- Count the transactions of all the addresses, each once even when it - -- touches several of them. The entries of an address are sorted, and the - -- same transaction has the same key after the address prefix in every - -- address, so merge the addresses by those raw key bytes and count the - -- distinct ones, without decoding any key or reading any value. - xPubTxCount _xspec xbals = do - withMetrics $ \s -> incrementCounter s.dataXPubTxCount 1 - db <- asks (.db) - let as = - map (.address) $ - filter (not . nullBalance) $ - map (.balance) xbals - withManyIters db (addrTxCF db) (length as) $ \its -> - liftIO $ fromIntegral <$> countDistinctSuffixes (zip (map (encode . AddrTxKeyA) as) its) - --- | Number of distinct keys, after their prefix, in a set of iterators that --- each walk the keys with one prefix, in order. -countDistinctSuffixes :: [(BS.ByteString, Iterator)] -> IO Int -countDistinctSuffixes streams = do - heads <- mapM start streams - go 0 (Map.fromListWith (<>) [(k, [x]) | (k, x) <- catMaybes heads]) - where - start x@(pfx, it) = iterSeek it pfx >> current x - current x@(pfx, it) = - iterKey it <&> \case - Just k | pfx `BS.isPrefixOf` k -> Just (BS.drop (BS.length pfx) k, x) - _ -> Nothing - advance x@(_, it) = iterNext it >> current x - go !n m = case Map.minViewWithKey m of - Nothing -> return n - Just ((_, xs), m') -> do - nexts <- catMaybes <$> mapM advance xs - go (n + 1) (foldr (\(k, x) -> Map.insertWith (<>) k [x]) m' nexts) diff --git a/src/Haskoin/Store/Database/Types.hs b/src/Haskoin/Store/Database/Types.hs --- a/src/Haskoin/Store/Database/Types.hs +++ b/src/Haskoin/Store/Database/Types.hs @@ -1,56 +1,77 @@ {-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ImportQualifiedPost #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE NoFieldSelectors #-} -{- | -Module : Haskoin.Store.Database.Types -Copyright : (c) Haskoin Developers -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -Keys and values stored in RocksDB. - -Every key type serializes to a distinct first byte, so that keys of different -types never collide even when they share a column family. Many key types -have short variants (suffixed @A@, @B@ or @S@) that serialize to a prefix of -the full key, for use with the prefix queries of "Database.RocksDB.Query". - -+-----------+--------------+----------------------------------------+ -| Prefix | Key | Value | -+===========+==============+========================================+ -| 32 x 0x00 | 'BestKey' | hash of the best block | -+-----------+--------------+----------------------------------------+ -| 0x01 | 'BlockKey' | 'BlockData' | -+-----------+--------------+----------------------------------------+ -| 0x02 | 'TxKey' | 'TxData' | -+-----------+--------------+----------------------------------------+ -| 0x03 | 'HeightKey' | hashes of the blocks at a height | -+-----------+--------------+----------------------------------------+ -| 0x04 | 'BalKey' | 'BalVal' | -+-----------+--------------+----------------------------------------+ -| 0x05 | 'AddrTxKey' | nothing | -+-----------+--------------+----------------------------------------+ -| 0x06 | 'AddrOutKey' | 'OutVal' | -+-----------+--------------+----------------------------------------+ -| 0x07 | 'MemKey' | whole mempool (legacy) | -+-----------+--------------+----------------------------------------+ -| 0x08 | 'MemTxKey' | time a transaction entered the mempool | -+-----------+--------------+----------------------------------------+ -| 0x09 | 'UnspentKey' | 'UnspentVal' | -+-----------+--------------+----------------------------------------+ -| 0x0a | 'VersionKey' | database version | -+-----------+--------------+----------------------------------------+ -| 0x0b | 'MemTimeKey' | nothing | -+-----------+--------------+----------------------------------------+ --} +-- | +-- Module : Haskoin.Store.Database.Types +-- Copyright : (c) Haskoin Developers +-- License : MIT +-- Maintainer : jprupp@protonmail.ch +-- Stability : experimental +-- Portability : POSIX +-- +-- Keys and values stored in RocksDB. +-- +-- Every key type serializes to a distinct first byte, so that keys of different +-- types never collide even when they share a column family. Many key types +-- have short variants (suffixed @A@, @B@ or @S@) that serialize to a prefix of +-- the full key, for use with the prefix queries of "Database.RocksDB.Query". +-- +-- +-----------+--------------+----------------------------------------+ +-- | Prefix | Key | Value | +-- +===========+==============+========================================+ +-- | 32 x 0x00 | 'BestKey' | hash of the best block | +-- +-----------+--------------+----------------------------------------+ +-- | 0x01 | 'BlockKey' | 'BlockData' | +-- +-----------+--------------+----------------------------------------+ +-- | 0x02 | 'TxKey' | 'TxData' | +-- +-----------+--------------+----------------------------------------+ +-- | 0x03 | 'HeightKey' | hashes of the blocks at a height | +-- +-----------+--------------+----------------------------------------+ +-- | 0x04 | 'BalKey' | 'BalVal' | +-- +-----------+--------------+----------------------------------------+ +-- | 0x05 | 'AddrTxKey' | nothing | +-- +-----------+--------------+----------------------------------------+ +-- | 0x06 | 'AddrOutKey' | 'OutVal' | +-- +-----------+--------------+----------------------------------------+ +-- | 0x07 | 'MemKey' | whole mempool (legacy) | +-- +-----------+--------------+----------------------------------------+ +-- | 0x08 | 'MemTxKey' | time a transaction entered the mempool | +-- +-----------+--------------+----------------------------------------+ +-- | 0x09 | 'UnspentKey' | 'UnspentVal' | +-- +-----------+--------------+----------------------------------------+ +-- | 0x0a | 'VersionKey' | database version | +-- +-----------+--------------+----------------------------------------+ +-- | 0x0b | 'MemTimeKey' | nothing | +-- +-----------+--------------+----------------------------------------+ +-- +-- = Keys of the layered layout +-- +-- They belong to the layout that the store runs on, that of +-- @docs\/layered-database.md@, version 22, in which the column families of +-- the chain hold nothing from the mempool and everything about the mempool +-- is in two column families of its own. t'TxKey' is used there too, for the +-- bodies of mempool transactions. "Haskoin.Store.Database.Mempool" reads +-- and writes them, and "Haskoin.Store.Database.Migrate" moves a database of +-- version 20 to that layout. +-- +-- +-----------+------------------+-------------------------------------------+ +-- | Prefix | Key | Value | +-- +===========+==================+===========================================+ +-- | 0x0c | t'MemSpenderKey' | 'Spender': mempool input that spends an | +-- | | | output | +-- +-----------+------------------+-------------------------------------------+ +-- | 0x0d | 'MemAddrKey' | 'MemAddrVal': what the mempool does at an | +-- | | | address | +-- +-----------+------------------+-------------------------------------------+ +-- | 0x0e | t'MemDeletedKey' | 'TxData' of a transaction that left the | +-- | | | mempool unconfirmed: not written any more | +-- +-----------+------------------+-------------------------------------------+ +-- | 0x0f | t'MigrationKey' | version a migration in progress started | +-- | | | from | +-- +-----------+------------------+-------------------------------------------+ +-- | 0x10 | t'SpenderKey' | t'SpenderVal': inputs of blocks that | +-- | | | spend outputs of a transaction | +-- +-----------+------------------+-------------------------------------------+ module Haskoin.Store.Database.Types ( AddrTxKey (..), AddrOutKey (..), @@ -61,6 +82,16 @@ MemKey (..), MemTxKey (..), MemTimeKey (..), + MemSpenderKey (..), + MemAddrKey (..), + MemAddrVal (..), + MemSummary (..), + MemDeletedKey (..), + MigrationKey (..), + SpenderKey (..), + SpenderVal (..), + spenderGroup, + spenderKey, TxKey (..), decodeTxKey, UnspentKey (..), @@ -77,7 +108,7 @@ where import Control.DeepSeq (NFData) -import Control.Monad (guard) +import Control.Monad (forM_, guard, replicateM) import Data.Bits ( shift, (.&.), @@ -86,8 +117,11 @@ import Data.ByteString qualified as BS import Data.Default (Default (..)) import Data.Hashable (Hashable) +import Data.IntMap.Strict (IntMap) +import Data.IntMap.Strict qualified as IntMap import Data.Serialize - ( Serialize (..), + ( Get, + Serialize (..), getBytes, getWord16be, getWord32be, @@ -116,6 +150,7 @@ ( Balance (..), BlockData, BlockRef, + Spender, TxData, TxRef (..), UnixTime, @@ -337,7 +372,7 @@ -- | Index of the mempool by the time each transaction entered it, in the -- mempool column family next to 'MemTxKey'. Keys sort by time, then by --- hash, as the pairs in 'getMempool' do, so a page of the mempool is read +-- hash, as the pairs in @getMempool@ do, so a page of the mempool is read -- with a short scan instead of loading and sorting every entry. data MemTimeKey = -- | entry of a mempool transaction, by time and hash @@ -362,9 +397,330 @@ instance KeyValue MemTimeKey () +-- | Key of the input of a mempool transaction that spends an output, in the +-- mempool column family of the layered layout. The output may be one of a +-- confirmed transaction or of another mempool transaction: the key is the +-- same, so nothing has to change here when the transaction that created the +-- output is confirmed. +-- +-- Spenders in the chain's column families are part of the body of the +-- transaction whose output they spend. A mempool spender cannot be: writing +-- it there would let the mempool change the data of the chain. +data MemSpenderKey + = -- | key of the mempool spender of an output + MemSpenderKey !OutPoint + | -- | short key that matches the mempool spenders of the outputs of a + -- transaction + MemSpenderKeyS !TxHash + | -- | short key that matches every mempool spender + MemSpenderKeyB + deriving (Show, Read, Eq, Ord, Generic, Hashable) + +instance Serialize MemSpenderKey where + -- 0x0c · TxHash · Index + put (MemSpenderKey OutPoint {hash = h, index = i}) = do + put (MemSpenderKeyS h) + put i + -- 0x0c · TxHash + put (MemSpenderKeyS h) = do + put MemSpenderKeyB + put h + -- 0x0c + put MemSpenderKeyB = putWord8 0x0c + get = do + guard . (== 0x0c) =<< getWord8 + h <- get + i <- get + return $ MemSpenderKey OutPoint {hash = h, index = i} + +instance Key MemSpenderKey + +instance KeyValue MemSpenderKey Spender + +-- | Key of something that the mempool does at an address, in the column +-- family of mempool address records of the layered layout. There are three +-- kinds, and all those of an address are read with one scan of its prefix. +-- +-- Every entry depends on one mempool transaction alone: on its inputs, with +-- the outputs they spend, and on its outputs. None says whether an output +-- that is spent was created by a confirmed transaction or by another +-- mempool transaction, nor whether an output that is created is spent. So +-- a transaction is added by writing its entries and removed by deleting +-- them, whatever else is in the mempool, and nothing here changes when a +-- block confirms some transactions and not others. What a query needs is +-- worked out from the entries of the address when it is answered; see +-- "Haskoin.Store.Database.Mempool". +-- +-- Times are stored complemented, as in a mempool 'BlockRef', so that entries +-- come out newest first, which is the order of the API. +data MemAddrKey + = -- | a mempool transaction that spends from or pays to the address, by + -- the time it entered the mempool + MemAddrTxKey !Address !UnixTime !TxHash + | -- | an output of the address that a mempool transaction spends + MemAddrSpentKey !Address !OutPoint + | -- | an output that a mempool transaction pays to the address, spent or + -- not, by the time the transaction entered the mempool + MemAddrOutKey !Address !UnixTime !OutPoint + | -- | what the entries of an address add up to; see t'MemSummary' + MemAddrSumKey !Address + | -- | short key that matches the transactions of an address + MemAddrTxKeyA !Address + | -- | short key that matches the outputs paid to an address + MemAddrOutKeyA !Address + | -- | short key that matches every entry of an address + MemAddrKeyA !Address + | -- | short key that matches the entries of every address + MemAddrKeyS + deriving (Show, Eq, Ord, Generic, Hashable) + +instance Serialize MemAddrKey where + -- 0x0d · Address · 0x00 · time · TxHash + put (MemAddrTxKey a t h) = do + put (MemAddrKeyA a) + putWord8 0x00 + putWord64be (maxBound - t) + put h + -- 0x0d · Address · 0x01 · OutPoint + put (MemAddrSpentKey a p) = do + put (MemAddrKeyA a) + putWord8 0x01 + put p + -- 0x0d · Address · 0x02 · time · OutPoint + put (MemAddrOutKey a t p) = do + put (MemAddrKeyA a) + putWord8 0x02 + putWord64be (maxBound - t) + put p + -- 0x0d · Address · 0x03 + put (MemAddrSumKey a) = do + put (MemAddrKeyA a) + putWord8 0x03 + -- 0x0d · Address · 0x00 + put (MemAddrTxKeyA a) = do + put (MemAddrKeyA a) + putWord8 0x00 + -- 0x0d · Address · 0x02 + put (MemAddrOutKeyA a) = do + put (MemAddrKeyA a) + putWord8 0x02 + -- 0x0d · Address + put (MemAddrKeyA a) = do + put MemAddrKeyS + put a + -- 0x0d + put MemAddrKeyS = putWord8 0x0d + get = do + guard . (== 0x0d) =<< getWord8 + a <- get + getWord8 >>= \case + 0x00 -> MemAddrTxKey a . (maxBound -) <$> getWord64be <*> get + 0x01 -> MemAddrSpentKey a <$> get + 0x02 -> MemAddrOutKey a . (maxBound -) <$> getWord64be <*> get + 0x03 -> return (MemAddrSumKey a) + _ -> fail "Cannot decode MemAddrKey" + +instance Key MemAddrKey + +-- | Value of a 'MemAddrKey': nothing for a transaction, the amount in +-- satoshi of an output that is spent, and the amount and script of an output +-- that is created. The first byte says which, so that a value can be decoded +-- without its key. +data MemAddrVal + = -- | value of a 'MemAddrTxKey' + MemAddrTxVal + | -- | value of a 'MemAddrSpentKey': amount of the output + MemAddrSpentVal !Word64 + | -- | value of a 'MemAddrOutKey': amount and script of the output + MemAddrOutVal !Word64 !ByteString + | -- | value of a 'MemAddrSumKey' + MemAddrSumVal !MemSummary + deriving (Show, Read, Eq, Ord, Generic, Hashable, NFData) + +-- | What the entries of an address in the mempool area add up to, kept so +-- that its balance is one read by key however many entries there are, and +-- so that an address with nothing in the mempool is found by a key that is +-- not there instead of a scan. +-- +-- It is a function of the entries of the address, and of nothing else: not +-- of the chain. Whether an output that the mempool spends is one of the +-- chain or one that the mempool made is the difference between 'spent' and +-- 'both', and 'both' only changes when one of the two transactions enters +-- or leaves the mempool. So the summary stays right when a block confirms +-- some transactions and not others, like the entries themselves. +data MemSummary = MemSummary + { -- | mempool transactions that touch the address + txs :: !Word64, + -- | amount of the outputs that the mempool pays to the address + paid :: !Word64, + -- | number of those outputs + paidCount :: !Word64, + -- | amount of the outputs of the address that the mempool spends + spent :: !Word64, + -- | number of those outputs + spentCount :: !Word64, + -- | amount of the outputs that the mempool both pays and spends + both :: !Word64, + -- | number of those outputs + bothCount :: !Word64 + } + deriving (Show, Read, Eq, Ord, Generic, Hashable, Serialize, NFData) + +instance Serialize MemAddrVal where + put MemAddrTxVal = putWord8 0x00 + put (MemAddrSpentVal v) = putWord8 0x01 >> putWord64be v + put (MemAddrOutVal v s) = putWord8 0x02 >> putWord64be v >> put s + put (MemAddrSumVal s) = putWord8 0x03 >> put s + get = + getWord8 >>= \case + 0x00 -> return MemAddrTxVal + 0x01 -> MemAddrSpentVal <$> getWord64be + 0x02 -> MemAddrOutVal <$> getWord64be <*> get + 0x03 -> MemAddrSumVal <$> get + _ -> fail "Cannot decode MemAddrVal" + +instance KeyValue MemAddrKey MemAddrVal + +-- | Key of the body of a transaction that left the mempool without being +-- confirmed, in the mempool column family of the layered layout: it was +-- replaced, it conflicted with a block, or it was too old. The store keeps +-- such bodies, marked as deleted, so that the API can go on saying what +-- became of a transaction that it once showed. +-- +-- Version 20 keeps them in the column family of transactions, under +-- t'TxKey'. There, deleting a mempool transaction writes to the data of the +-- chain, which the layered layout does not allow. +-- +-- Nothing writes or reads this key any more: since version 22 the store +-- keeps nothing of a transaction that leaves the mempool unconfirmed. A +-- database that has some has them until its mempool is wiped. +data MemDeletedKey + = -- | key of a deleted transaction + MemDeletedKey !TxHash + | -- | short key that matches the deleted transactions whose hash starts + -- with these six bytes, as 'TxKeyS' does for the others; see + -- 'decodeTxKey' + MemDeletedKeyP !(Word32, Word16) + | -- | short key that matches every deleted transaction + MemDeletedKeyS + deriving (Show, Read, Eq, Ord, Generic, Hashable) + +instance Serialize MemDeletedKey where + -- 0x0e · TxHash + put (MemDeletedKey h) = do + put MemDeletedKeyS + put h + -- 0x0e · first six bytes of a TxHash + put (MemDeletedKeyP h) = do + put MemDeletedKeyS + put h + -- 0x0e + put MemDeletedKeyS = putWord8 0x0e + get = do + guard . (== 0x0e) =<< getWord8 + MemDeletedKey <$> get + +instance Key MemDeletedKey + +instance KeyValue MemDeletedKey TxData + +-- | Key that is present while a migration of the database is under way, +-- with the version that it started from. A migration that works in several +-- batches sets it with the first and removes it with the last, so that a +-- store that finds it knows to carry on, whatever the version says. +data MigrationKey = MigrationKey + deriving (Eq, Show, Read, Ord, Generic, Hashable) + +instance Serialize MigrationKey where + -- 0x0f + put MigrationKey = putWord8 0x0f + get = do + guard . (== 0x0f) =<< getWord8 + return MigrationKey + +instance Key MigrationKey + +instance KeyValue MigrationKey Word32 + +-- | Key of the inputs of blocks that spend some outputs of a transaction, +-- in the @spender@ column family, since database version 22: the +-- transaction, and the number of a group of 'spenderGroup' of its outputs +-- that follow each other. The value has the spender of each output of the +-- group that is spent in a t'SpenderVal'. +-- +-- Until then the spenders of the outputs of a confirmed transaction were in +-- its own record, 'TxData', which was read and written whole again every +-- time a block spent one of them or was reverted: once for each of its +-- outputs, over years, for a record of any size. Now the record of a +-- transaction is written when a block confirms it and never again, and +-- spending an output reads and writes a value of a few dozen bytes. +-- +-- = Why groups +-- +-- A key for each spent output would make a spend one write that reads +-- nothing. But a transaction is read far more often than it is spent +-- from, and has to be read with its spenders: that would take a key for +-- each of its outputs, with each read of it. One value +-- for all the outputs of a transaction would cost one key to read, and +-- bring back the trouble with large transactions: a payout to ten +-- thousand would rewrite half a megabyte ten thousand times. With groups +-- of sixteen nearly every transaction has one key, and no value is larger +-- than sixteen spenders. +-- +-- The groups of a transaction are next to each other, so all its spenders +-- can also be read with one scan of their common prefix, which is what the +-- prefix of the column family is. +data SpenderKey + = -- | spenders of a group of outputs of a transaction + SpenderKey !TxHash !Word32 + | -- | short key that matches the groups of a transaction + SpenderKeyS !TxHash + deriving (Show, Read, Eq, Ord, Generic, Hashable) + +instance Serialize SpenderKey where + -- 0x10 · TxHash · group + put (SpenderKey h g) = do + put (SpenderKeyS h) + put g + -- 0x10 · TxHash + put (SpenderKeyS h) = do + putWord8 0x10 + put h + get = do + guard . (== 0x10) =<< getWord8 + h <- get + SpenderKey h <$> get + +instance Key SpenderKey + +instance KeyValue SpenderKey SpenderVal + +-- | The number of outputs whose spenders are under one t'SpenderKey'. +spenderGroup :: Word32 +spenderGroup = 16 + +-- | The key that has the spender of an output. +spenderKey :: OutPoint -> SpenderKey +spenderKey p = SpenderKey p.hash (p.index `div` spenderGroup) + +-- | The inputs of blocks that spend outputs of a group, by the number of +-- the output in its transaction. A group none of whose outputs is spent +-- has no key. +newtype SpenderVal = SpenderVal (IntMap Spender) + deriving (Show, Eq) + +instance Serialize SpenderVal where + put (SpenderVal m) = do + putWord8 (fromIntegral (IntMap.size m)) + forM_ (IntMap.toAscList m) $ \(i, spender) -> put (fromIntegral i :: Word32) >> put spender + get = do + n <- getWord8 + SpenderVal . IntMap.fromList <$> replicateM (fromIntegral n) ((,) . fromIntegral <$> (get :: Get Word32) <*> get) + -- | Block entry database key. newtype BlockKey = BlockKey BlockHash - deriving (Show, Read, Eq, Ord, Generic, Hashable) + deriving stock (Show, Read, Eq, Ord, Generic) + deriving anyclass (Hashable) instance Serialize BlockKey where -- 0x01 · BlockHash @@ -381,7 +737,8 @@ -- | Block height database key. newtype HeightKey = HeightKey BlockHeight - deriving (Show, Read, Eq, Ord, Generic, Hashable) + deriving stock (Show, Read, Eq, Ord, Generic) + deriving anyclass (Hashable) instance Serialize HeightKey where -- 0x03 · BlockHeight diff --git a/src/Haskoin/Store/Database/Views.hs b/src/Haskoin/Store/Database/Views.hs new file mode 100644 --- /dev/null +++ b/src/Haskoin/Store/Database/Views.hs @@ -0,0 +1,136 @@ +-- | +-- Module : Haskoin.Store.Database.Views +-- Copyright : (c) Haskoin Developers +-- License : MIT +-- Maintainer : jprupp@protonmail.ch +-- Stability : experimental +-- Portability : POSIX +-- +-- The database as it was at each of its recent blocks: a RocksDB snapshot +-- for each, kept until it is no longer needed. Nothing in the store uses +-- this yet. It is the first part of the store's side of "A fleet that +-- answers as one" in @docs\/layered-database.md@. +-- +-- = Why +-- +-- Stores that share a Redis all answer from one block, the fleet tip +-- ("Haskoin.Store.Fleet"), which is usually not the newest block that a +-- store has: the tip waits for the slowest store. So a store has to be able +-- to answer from a block that it has already built on, and a snapshot is how +-- RocksDB gives the database as it was. A snapshot cannot be taken of the +-- past, only of the present, so the store takes one as each block is +-- imported and keeps it. +-- +-- = Letting go +-- +-- RocksDB holds on to every version of a key that a snapshot can see, so +-- snapshots are let go as soon as the rules of the fleet allow ('keepViews'). +-- A request may be reading through one at that moment. Releasing it then +-- would hand RocksDB freed memory, so each view counts its readers, and one +-- that is let go while it is read is released when the last reader is done. +-- +-- The blocks can be of any type that can be compared, as in +-- "Haskoin.Store.Fleet". +module Haskoin.Store.Database.Views + ( Views, + newViews, + closeViews, + takeView, + heldViews, + keepViews, + withViewAt, + ) +where + +import Control.Monad (forM_, when) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Database.RocksDB (DB, Snapshot, createSnapshot, releaseSnapshot) +import Haskoin.Store.Database.Reader (DatabaseReader (..)) +import UnliftIO + ( TVar, + atomically, + bracket, + mask_, + newTVarIO, + readTVar, + readTVarIO, + stateTVar, + writeTVar, + ) + +-- | The views of a database, by block. +data Views b = Views + { reader :: !DatabaseReader, + held :: !(TVar (Map b Held)) + } + +-- | A snapshot, the number of readers that are using it, and whether it is +-- to be released when the last of them is done. +data Held = Held + { snapshot :: !(DB, Snapshot), + readers :: !Int, + doomed :: !Bool + } + +-- | No views yet, of a database. +newViews :: DatabaseReader -> IO (Views b) +newViews reader = Views reader <$> newTVarIO Map.empty + +-- | Take a view of the database as it is now, for a block. The caller must +-- be the one that writes to the database, between the import of that block +-- and its next write, so that the view is of that block and nothing else. +-- A view that the block already has is kept, and is no longer to be +-- released: a block that comes back after a reorganisation is the same +-- block. +takeView :: (Ord b) => Views b -> b -> IO () +takeView views block = mask_ $ do + fresh <- createSnapshot views.reader.db + spare <- atomically . stateTVar views.held $ \m -> case Map.lookup block m of + Just old -> (True, Map.insert block old {doomed = False} m) + Nothing -> (False, Map.insert block Held {snapshot = fresh, readers = 0, doomed = False} m) + when spare (releaseSnapshot fresh) + +-- | The blocks that there is a view of and that is not on its way out. +heldViews :: Views b -> IO [b] +heldViews views = Map.keys . Map.filter (not . (.doomed)) <$> readTVarIO views.held + +-- | Let go of every view but those of the given blocks. A view that is +-- being read is released when its last reader is done, and counts as gone +-- from now on. +keepViews :: (Ord b) => Views b -> [b] -> IO () +keepViews views blocks = mask_ $ do + free <- atomically . stateTVar views.held $ \m -> + let (stay, go) = Map.partitionWithKey (\b _ -> b `elem` blocks) m + (idle, busy) = Map.partition ((== 0) . (.readers)) go + in (Map.elems idle, stay <> Map.map (\h -> h {doomed = True}) busy) + forM_ free (releaseSnapshot . (.snapshot)) + +-- | Run an action with the database as it was at a block, if there is a +-- view of it: a reader whose every read goes through the snapshot. The +-- reader must not be used after the action returns. +withViewAt :: (Ord b) => Views b -> b -> (DatabaseReader -> IO a) -> IO (Maybe a) +withViewAt views block action = bracket enter leave (mapM run) + where + enter = atomically $ do + m <- readTVar views.held + case Map.lookup block m of + Just h | not h.doomed -> do + writeTVar views.held (Map.insert block h {readers = h.readers + 1} m) + return (Just h) + _ -> return Nothing + run h = action views.reader {db = fst h.snapshot} + leave Nothing = return () + leave (Just _) = do + free <- atomically . stateTVar views.held $ \m -> case Map.lookup block m of + Just h + | h.readers <= 1 && h.doomed -> (Just h, Map.delete block m) + | otherwise -> (Nothing, Map.insert block h {readers = h.readers - 1} m) + Nothing -> (Nothing, m) + forM_ free (releaseSnapshot . (.snapshot)) + +-- | Release every view. None may be in use. +closeViews :: Views b -> IO () +closeViews views = mask_ $ do + m <- atomically (stateTVar views.held (,Map.empty)) + forM_ m (releaseSnapshot . (.snapshot)) diff --git a/src/Haskoin/Store/Database/Writer.hs b/src/Haskoin/Store/Database/Writer.hs --- a/src/Haskoin/Store/Database/Writer.hs +++ b/src/Haskoin/Store/Database/Writer.hs @@ -1,12 +1,4 @@ -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ImportQualifiedPost #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE NoFieldSelectors #-} -- | -- Module : Haskoin.Store.Database.Writer @@ -18,11 +10,15 @@ -- -- Buffered writes to the database. -- --- 'WriterT' implements 'StoreWrite' by recording every change in in-memory hash --- tables, and 'StoreReadBase' by reading those tables first and falling back to --- the database. When the action given to 'runWriter' finishes, all the changes --- are written to RocksDB in a single atomic batch. A block or a set of --- transactions is thus either fully imported or not at all. +-- A 'Writer' records every change in in-memory hash tables, and its reads look +-- in those tables first and fall back to the database. When the function given +-- to 'runWriter' returns, all the changes are written to RocksDB in a single +-- atomic batch. A block or a set of transactions is thus either fully imported +-- or not at all. +-- +-- The writer is a plain handle passed to plain functions in 'IO' ('getTxData', +-- 'insertTx', ...), rather than a monad transformer with class instances: the +-- import logic says which writer it uses, and needs nothing but 'IO' to run. -- = Why buffer writes -- -- Importing a block touches thousands of keys, and many of them several times: @@ -30,23 +26,84 @@ -- transaction of its address. Buffering collapses those into one final value per -- key, and a single atomic batch makes the whole import all-or-nothing. A crash -- or an invalid block leaves the database exactly as it was. +-- +-- = Two layouts +-- +-- The writes of the first groups below are to the column families that the +-- store uses today, where the chain and the mempool share their indices. +-- The last group is for the layered layout of @docs\/layered-database.md@, +-- in which the mempool has an area of its own: bodies, spenders, address +-- entries and deleted transactions of the mempool. A batch can write to +-- both areas, and is still one atomic write. Only +-- "Haskoin.Store.Logic.Layered" uses that group, on a database opened with +-- 'Haskoin.Store.Database.Reader.withLayeredReader'; a batch that does not +-- use it writes nothing there. module Haskoin.Store.Database.Writer - ( WriterT, + ( -- * Batches + Writer, MempoolChanges (..), runWriter, runWriterMempool, + writerNet, + writerCtx, writerLogger, + + -- * Reads, with the changes of the batch applied + getBestBlock, + getBlocksAtHeight, + getBlock, + getTxData, + getSpender, + getUnspent, + getBalance, + getMempool, + + -- * Writes + setBest, + insertBlock, + setBlocksAtHeight, + insertTx, + insertAddrTx, + deleteAddrTx, + insertAddrUnspent, + deleteAddrUnspent, + addToMempool, + deleteFromMempool, + inMempool, + setBalance, + insertUnspent, + deleteUnspent, + deleteTxData, + deleteBalance, + + -- * The mempool area of the layered layout + getMempoolTx, + getMempoolSpender, + getMempoolSpenders, + getChainSpender, + getChainSpenders, + insertSpender, + deleteSpender, + insertMempoolTx, + deleteMempoolTx, + insertMempoolSpender, + deleteMempoolSpender, + insertMempoolAddr, + deleteMempoolAddr, + getMempoolAddr, ) where import Control.Monad (forM) -import Control.Monad.Reader (ReaderT (..)) -import Control.Monad.Reader qualified as R +import Data.Functor ((<&>)) import Data.HashMap.Strict qualified as HashMap import Data.HashTable.IO qualified as H +import Data.IntMap.Strict (IntMap) import Data.IntMap.Strict qualified as IntMap import Data.List (sortOn) +import Data.Maybe (catMaybes, isJust) import Data.Ord (Down (..)) +import Data.Word (Word32) import Database.RocksDB (BatchOp, DB) import Database.RocksDB.Query ( deleteOp, @@ -68,20 +125,21 @@ txHash, ) import Haskoin.Node (Logger) -import Haskoin.Store.Common import Haskoin.Store.Data +import Haskoin.Store.Database.Mempool qualified as M +import Haskoin.Store.Database.Query qualified as Q import Haskoin.Store.Database.Reader import Haskoin.Store.Database.Types import UnliftIO ( IORef, - MonadIO, liftIO, newIORef, readIORef, writeIORef, ) --- | Environment of a batch of writes. +-- | A batch of writes: the database it reads from and writes to, the +-- changes made so far, and where to log. Make one with 'runWriter'. data Writer = Writer { -- | database to read from and write to reader :: !DatabaseReader, @@ -91,24 +149,17 @@ logger :: !Logger } --- | Monad transformer for a batch of writes. Run it with 'runWriter'. -type WriterT = ReaderT Writer +-- | Network of the database of a batch. +writerNet :: Writer -> Network +writerNet w = w.reader.net --- | Logger passed to 'runWriter'. -writerLogger :: (Monad m) => WriterT m Logger -writerLogger = R.asks (.logger) +-- | Secp256k1 context of the database of a batch. +writerCtx :: Writer -> Ctx +writerCtx w = w.reader.ctx -instance (MonadIO m) => StoreReadBase (WriterT m) where - getNetwork = R.asks (.reader.net) - getCtx = R.asks (.reader.ctx) - getBestBlock = getBestBlockI - getBlocksAtHeight = getBlocksAtHeightI - getBlock = getBlockI - getTxData = getTxDataI - getSpender = getSpenderI - getUnspent = getUnspentI - getBalance = getBalanceI - getMempool = getMempoolI +-- | Logger passed to 'runWriter'. +writerLogger :: Writer -> Logger +writerLogger w = w.logger -- | Change to the best block: 'Nothing' if unchanged, @Just Nothing@ if deleted. type BestRef = IORef (Maybe (Maybe BlockHash)) @@ -137,6 +188,15 @@ -- | Mempool changes in this batch: 'Nothing' for a deletion. type MempoolTable = H.BasicHashTable TxHash (Maybe UnixTime) +-- | Changed groups of spenders of outputs in the chain. +type SpenderTable = H.BasicHashTable (TxHash, Word32) (IntMap Spender) + +-- | Changed mempool spenders of outputs: 'Nothing' for a deletion. +type MemSpenderTable = H.BasicHashTable OutPoint (Maybe Spender) + +-- | Changed entries of the mempool by address: 'Nothing' for a deletion. +type MemAddrTable = H.BasicHashTable MemAddrKey (Maybe MemAddrVal) + -- | Changes made in a batch, not yet written to the database. data Memory = Memory { -- | network constants @@ -160,77 +220,128 @@ -- | address unspent outputs outputTable :: !AddrOutTable, -- | mempool - mempoolTable :: !MempoolTable + mempoolTable :: !MempoolTable, + -- | bodies of mempool transactions, in the mempool area + memTxTable :: !TxTable, + -- | mempool spenders of outputs, in the mempool area + memSpenderTable :: !MemSpenderTable, + -- | entries of the mempool by address, in the mempool area + memAddrTable :: !MemAddrTable, + -- | inputs of blocks that spend outputs, by group of outputs + -- as t'SpenderKey' says, each group as the batch leaves it: empty for one + -- that has no spent output left + spenderTable :: !SpenderTable } -instance (MonadIO m) => StoreWrite (WriterT m) where - setBest h = - ReaderT $ \Writer {memory = Memory {..}} -> - liftIO $ writeIORef best (Just (Just h)) - insertBlock b = - ReaderT $ \Writer {memory = Memory {..}} -> - liftIO $ H.insert blockTable (headerHash b.header) (Just b) - setBlocksAtHeight h g = - ReaderT $ \Writer {memory = Memory {..}} -> - liftIO $ H.insert heightTable g h - insertTx t = - ReaderT $ \Writer {memory = Memory {..}} -> - liftIO $ H.insert txTable (txHash t.tx) (Just t) - insertAddrTx a t = - ReaderT $ \Writer {memory = Memory {..}} -> - liftIO $ H.insert addressTable (a, t) (Just ()) - deleteAddrTx a t = - ReaderT $ \Writer {memory = Memory {..}} -> - liftIO $ H.insert addressTable (a, t) Nothing - insertAddrUnspent a u = - ReaderT $ \Writer {memory = Memory {..}} -> - liftIO $ H.insert outputTable k (Just v) - where - k = (a, u.block, u.outpoint) - v = OutVal u.value u.script - deleteAddrUnspent a u = - ReaderT $ \Writer {memory = Memory {..}} -> - liftIO $ H.insert outputTable k Nothing - where - k = (a, u.block, u.outpoint) - addToMempool x t = - ReaderT $ \Writer {memory = Memory {..}} -> - liftIO $ H.insert mempoolTable x (Just t) - deleteFromMempool x = - ReaderT $ \Writer {memory = Memory {..}} -> - liftIO $ H.insert mempoolTable x Nothing - setBalance b = - ReaderT $ \Writer {memory = Memory {..}} -> - liftIO $ H.insert balanceTable b.address (Just b) - insertUnspent u = - ReaderT $ \Writer {memory = Memory {..}} -> - liftIO $ H.insert unspentTable (fst (unspentToVal u)) (Just u) - deleteUnspent p = - ReaderT $ \Writer {memory = Memory {..}} -> - liftIO $ H.insert unspentTable p Nothing +-- | Set the best block. +setBest :: Writer -> BlockHash -> IO () +setBest w h = writeIORef w.memory.best (Just (Just h)) --- | Read a value from the changes of the batch, or from the database if the batch did not change it. -getLayered :: - (MonadIO m) => - (Memory -> IO (Maybe a)) -> - DatabaseReaderT m a -> - WriterT m a -getLayered f g = - ReaderT $ \Writer {reader = db, memory = s} -> - liftIO (f s) >>= \case - Just x -> return x - Nothing -> runReaderT g db +-- | Add or replace the data of a block. +insertBlock :: Writer -> BlockData -> IO () +insertBlock w b = H.insert w.memory.blockTable (headerHash b.header) (Just b) +-- | Set the hashes of the blocks at a height. +setBlocksAtHeight :: Writer -> [BlockHash] -> BlockHeight -> IO () +setBlocksAtHeight w h g = H.insert w.memory.heightTable g h + +-- | Add or replace the data of a transaction. +insertTx :: Writer -> TxData -> IO () +insertTx w t = H.insert w.memory.txTable (txHash t.tx) (Just t) + +-- | Add a transaction to the index of an address. +insertAddrTx :: Writer -> Address -> TxRef -> IO () +insertAddrTx w a t = H.insert w.memory.addressTable (a, t) (Just ()) + +-- | Remove a transaction from the index of an address. +deleteAddrTx :: Writer -> Address -> TxRef -> IO () +deleteAddrTx w a t = H.insert w.memory.addressTable (a, t) Nothing + +-- | Add an unspent output to the index of an address. +insertAddrUnspent :: Writer -> Address -> Unspent -> IO () +insertAddrUnspent w a u = + H.insert w.memory.outputTable (a, u.block, u.outpoint) (Just (OutVal u.value u.script)) + +-- | Remove an unspent output from the index of an address. +deleteAddrUnspent :: Writer -> Address -> Unspent -> IO () +deleteAddrUnspent w a u = + H.insert w.memory.outputTable (a, u.block, u.outpoint) Nothing + +-- | Add a transaction to the mempool with the time it arrived. +addToMempool :: Writer -> TxHash -> UnixTime -> IO () +addToMempool w x t = H.insert w.memory.mempoolTable x (Just t) + +-- | Remove a transaction from the mempool. +deleteFromMempool :: Writer -> TxHash -> IO () +deleteFromMempool w x = H.insert w.memory.mempoolTable x Nothing + +-- | Set the balance of an address. +setBalance :: Writer -> Balance -> IO () +setBalance w b = H.insert w.memory.balanceTable b.address (Just b) + +-- | Add an unspent output. +insertUnspent :: Writer -> Unspent -> IO () +insertUnspent w u = H.insert w.memory.unspentTable (fst (unspentToVal u)) (Just u) + +-- | Remove an unspent output. +deleteUnspent :: Writer -> OutPoint -> IO () +deleteUnspent w p = H.insert w.memory.unspentTable p Nothing + +-- | Remove the data of a transaction. +deleteTxData :: Writer -> TxHash -> IO () +deleteTxData w h = H.insert w.memory.txTable h Nothing + +-- | Remove the balance of an address, as that of one never used. +deleteBalance :: Writer -> Address -> IO () +deleteBalance w a = H.insert w.memory.balanceTable a Nothing + +-- | Add or replace the body of a mempool transaction in the mempool area. +insertMempoolTx :: Writer -> TxData -> IO () +insertMempoolTx w t = H.insert w.memory.memTxTable (txHash t.tx) (Just t) + +-- | Remove the body of a mempool transaction from the mempool area. +deleteMempoolTx :: Writer -> TxHash -> IO () +deleteMempoolTx w h = H.insert w.memory.memTxTable h Nothing + +-- | Record the mempool input that spends an output. +insertMempoolSpender :: Writer -> OutPoint -> Spender -> IO () +insertMempoolSpender w p s = H.insert w.memory.memSpenderTable p (Just s) + +-- | Forget the mempool input that spends an output. +deleteMempoolSpender :: Writer -> OutPoint -> IO () +deleteMempoolSpender w p = H.insert w.memory.memSpenderTable p Nothing + +-- | Add an entry of the mempool by address. +insertMempoolAddr :: Writer -> MemAddrKey -> MemAddrVal -> IO () +insertMempoolAddr w k v = H.insert w.memory.memAddrTable k (Just v) + +-- | Remove an entry of the mempool by address. +deleteMempoolAddr :: Writer -> MemAddrKey -> IO () +deleteMempoolAddr w k = H.insert w.memory.memAddrTable k Nothing + +-- | An entry of the mempool by address, with the changes of the batch +-- applied. +getMempoolAddr :: Writer -> MemAddrKey -> IO (Maybe MemAddrVal) +getMempoolAddr w k = getLayered w (\s -> H.lookup s.memAddrTable k) (\r -> retrieveCF r.db (mempoolAddrCF r.db) k) + +-- | Read a value from the changes of the batch, or from the database if the +-- batch did not change it. +getLayered :: Writer -> (Memory -> IO (Maybe a)) -> (DatabaseReader -> IO a) -> IO a +getLayered w f g = + f w.memory >>= \case + Just x -> return x + Nothing -> g w.reader + -- | Run a batch of writes and commit all its changes to the database in one --- atomic write. Reads within the batch see its own changes. +-- atomic write. Reads within the batch see its own changes. If the function +-- throws, nothing is written. runWriter :: - (MonadIO m) => Network -> Ctx -> DatabaseReader -> Logger -> - WriterT m a -> - m a + (Writer -> IO a) -> + IO a runWriter net ctx bdb logger f = fst <$> runWriterMempool net ctx bdb logger f @@ -247,23 +358,22 @@ -- | Like 'runWriter', but also say how the batch changed the mempool, so -- that callers do not have to read the whole mempool before and after. runWriterMempool :: - (MonadIO m) => Network -> Ctx -> DatabaseReader -> Logger -> - WriterT m a -> - m (a, MempoolChanges) + (Writer -> IO a) -> + IO (a, MempoolChanges) runWriterMempool net ctx bdb@DatabaseReader {db} logger f = do hm <- newMemory net ctx - x <- R.runReaderT f Writer {reader = bdb, memory = hm, logger} + x <- f Writer {reader = bdb, memory = hm, logger} ops <- hashMapOps db hm (mops, changes) <- mempoolOps db hm.mempoolTable - liftIO $ writeBatch db (ops <> mops) + writeBatch db (ops <> mops) return (x, changes) -- | Database operations for all changes of a batch except the mempool. -hashMapOps :: (MonadIO m) => DB -> Memory -> m [BatchOp] +hashMapOps :: DB -> Memory -> IO [BatchOp] hashMapOps db Memory {..} = mconcat <$> sequence @@ -274,11 +384,15 @@ balOps db balanceTable, addrTxOps db addressTable, addrOutOps db outputTable, - unspentOps db unspentTable + unspentOps db unspentTable, + memTxOps db memTxTable, + memSpenderOps db memSpenderTable, + memAddrOps db memAddrTable, + spenderOps db spenderTable ] -- | Operation for the change of the best block, if any. -bestBlockOp :: (MonadIO m) => BestRef -> m [BatchOp] +bestBlockOp :: BestRef -> IO [BatchOp] bestBlockOp r = readIORef r >>= \case Nothing -> return [] @@ -286,42 +400,42 @@ Just (Just b) -> return [insertOp BestKey b] -- | Operations for changed blocks. -blockHashOps :: (MonadIO m) => DB -> BlockTable -> m [BatchOp] -blockHashOps db t = map (uncurry f) <$> liftIO (H.toList t) +blockHashOps :: DB -> BlockTable -> IO [BatchOp] +blockHashOps db t = map (uncurry f) <$> (H.toList t) where f k (Just d) = insertOpCF (blockCF db) (BlockKey k) d f k Nothing = deleteOpCF (blockCF db) (BlockKey k) -- | Operations for changed block heights. -blockHeightOps :: (MonadIO m) => DB -> HeightTable -> m [BatchOp] -blockHeightOps db t = map (uncurry f) <$> liftIO (H.toList t) +blockHeightOps :: DB -> HeightTable -> IO [BatchOp] +blockHeightOps db t = map (uncurry f) <$> (H.toList t) where f = insertOpCF (heightCF db) . HeightKey -- | Operations for changed transactions. -txOps :: (MonadIO m) => DB -> TxTable -> m [BatchOp] -txOps db t = map (uncurry f) <$> liftIO (H.toList t) +txOps :: DB -> TxTable -> IO [BatchOp] +txOps db t = map (uncurry f) <$> (H.toList t) where f k (Just t') = insertOpCF (txCF db) (TxKey k) t' f k Nothing = deleteOpCF (txCF db) (TxKey k) -- | Operations for changed balances. -balOps :: (MonadIO m) => DB -> BalanceTable -> m [BatchOp] -balOps db t = map (uncurry f) <$> liftIO (H.toList t) +balOps :: DB -> BalanceTable -> IO [BatchOp] +balOps db t = map (uncurry f) <$> (H.toList t) where f a (Just b) = insertOpCF (balanceCF db) (BalKey a) (balanceToVal b) f a Nothing = deleteOpCF (balanceCF db) (BalKey a) -- | Operations for changed address transactions. -addrTxOps :: (MonadIO m) => DB -> AddrTxTable -> m [BatchOp] -addrTxOps db t = map (uncurry f) <$> liftIO (H.toList t) +addrTxOps :: DB -> AddrTxTable -> IO [BatchOp] +addrTxOps db t = map (uncurry f) <$> (H.toList t) where f (a, t') (Just ()) = insertOpCF (addrTxCF db) (AddrTxKey a t') () f (a, t') Nothing = deleteOpCF (addrTxCF db) (AddrTxKey a t') -- | Operations for changed address unspent outputs. -addrOutOps :: (MonadIO m) => DB -> AddrOutTable -> m [BatchOp] -addrOutOps db t = map (uncurry f) <$> liftIO (H.toList t) +addrOutOps :: DB -> AddrOutTable -> IO [BatchOp] +addrOutOps db t = map (uncurry f) <$> (H.toList t) where f (a, b, p) (Just l) = insertOpCF @@ -337,8 +451,8 @@ -- compared to the database: its time is needed to update the index by -- time, and the comparison says which transactions really entered or left -- the mempool. -mempoolOps :: (MonadIO m) => DB -> MempoolTable -> m ([BatchOp], MempoolChanges) -mempoolOps db t = liftIO $ do +mempoolOps :: DB -> MempoolTable -> IO ([BatchOp], MempoolChanges) +mempoolOps db t = do changes <- H.toList t rows <- forM changes $ \(h, new) -> do old <- retrieveCF db cf (MemTxKey h) @@ -360,62 +474,175 @@ | o == n = [] | otherwise = deleteOpCF cf (MemTimeKey o h) : mempoolInsertOps db h n +-- | Operations for changed bodies of mempool transactions. +memTxOps :: DB -> TxTable -> IO [BatchOp] +memTxOps db t = map (uncurry f) <$> H.toList t + where + f h (Just td) = insertOpCF (mempoolCF db) (TxKey h) td + f h Nothing = deleteOpCF (mempoolCF db) (TxKey h) + +-- | Operations for the changed groups of spenders of the chain. +spenderOps :: DB -> SpenderTable -> IO [BatchOp] +spenderOps db t = map (uncurry f) <$> H.toList t + where + f (h, g) m + | IntMap.null m = deleteOpCF (spenderCF db) (SpenderKey h g) + | otherwise = insertOpCF (spenderCF db) (SpenderKey h g) (SpenderVal m) + +-- | Operations for changed mempool spenders. +memSpenderOps :: DB -> MemSpenderTable -> IO [BatchOp] +memSpenderOps db t = map (uncurry f) <$> H.toList t + where + f p (Just s) = insertOpCF (mempoolCF db) (MemSpenderKey p) s + f p Nothing = deleteOpCF (mempoolCF db) (MemSpenderKey p) + +-- | Operations for changed entries of the mempool by address. Their column +-- family is only looked up if there are any, as a database of the layout in +-- use today does not have it. +memAddrOps :: DB -> MemAddrTable -> IO [BatchOp] +memAddrOps db t = map (uncurry f) <$> H.toList t + where + f k (Just v) = insertOpCF (mempoolAddrCF db) k v + f k Nothing = deleteOpCF (mempoolAddrCF db) k + -- | Operations for changed unspent outputs. -unspentOps :: (MonadIO m) => DB -> UnspentTable -> m [BatchOp] -unspentOps db t = map (uncurry f) <$> liftIO (H.toList t) +unspentOps :: DB -> UnspentTable -> IO [BatchOp] +unspentOps db t = map (uncurry f) <$> (H.toList t) where f p (Just u) = insertOpCF (unspentCF db) (UnspentKey p) (snd (unspentToVal u)) f p Nothing = deleteOpCF (unspentCF db) (UnspentKey p) --- | Read the best block, with the changes of the batch applied. -getBestBlockI :: (MonadIO m) => WriterT m (Maybe BlockHash) -getBestBlockI = getLayered getBestBlockH getBestBlock +-- | Best block, with the changes of the batch applied. +getBestBlock :: Writer -> IO (Maybe BlockHash) +getBestBlock w = getLayered w getBestBlockH Q.getBestBlock --- | Read the blocks at a height, with the changes of the batch applied. -getBlocksAtHeightI :: (MonadIO m) => BlockHeight -> WriterT m [BlockHash] -getBlocksAtHeightI bh = - getLayered (getBlocksAtHeightH bh) (getBlocksAtHeight bh) +-- | Blocks at a height, with the changes of the batch applied. +getBlocksAtHeight :: Writer -> BlockHeight -> IO [BlockHash] +getBlocksAtHeight w bh = getLayered w (getBlocksAtHeightH bh) (`Q.getBlocksAtHeight` bh) --- | Read a block, with the changes of the batch applied. -getBlockI :: (MonadIO m) => BlockHash -> WriterT m (Maybe BlockData) -getBlockI bh = getLayered (getBlockH bh) (getBlock bh) +-- | Data of a block, with the changes of the batch applied. +getBlock :: Writer -> BlockHash -> IO (Maybe BlockData) +getBlock w bh = getLayered w (getBlockH bh) (`Q.getBlock` bh) --- | Read a transaction, with the changes of the batch applied. -getTxDataI :: (MonadIO m) => TxHash -> WriterT m (Maybe TxData) -getTxDataI th = getLayered (getTxDataH th) (getTxData th) +-- | Data of a transaction, deleted ones included, with the changes of the +-- batch applied. +getTxData :: Writer -> TxHash -> IO (Maybe TxData) +getTxData w th = getLayered w (getTxDataH th) (`Q.getTxRecord` th) --- | Read the spender of an output, with the changes of the batch applied. -getSpenderI :: (MonadIO m) => OutPoint -> WriterT m (Maybe Spender) -getSpenderI op = getLayered (getSpenderH op) (getSpender op) +-- | Spender of an output, with the changes of the batch applied. +getSpender :: Writer -> OutPoint -> IO (Maybe Spender) +getSpender w op = getLayered w (getSpenderH op) fromRecord + where + -- the rules of version 20 keep spenders in the record of the + -- transaction that made the output, and this is theirs + fromRecord r = (>>= IntMap.lookup (fromIntegral op.index) . (.spenders)) <$> Q.getTxRecord r op.hash --- | Read the balance of an address, with the changes of the batch applied. -getBalanceI :: (MonadIO m) => Address -> WriterT m (Maybe Balance) -getBalanceI a = getLayered (getBalanceH a) (getBalance a) +-- | Balance of an address, with the changes of the batch applied. +getBalance :: Writer -> Address -> IO (Maybe Balance) +getBalance w a = getLayered w (getBalanceH a) (`Q.getBalance` a) --- | Read an unspent output, with the changes of the batch applied. -getUnspentI :: (MonadIO m) => OutPoint -> WriterT m (Maybe Unspent) -getUnspentI op = getLayered (getUnspentH op) (getUnspent op) +-- | Unspent output, with the changes of the batch applied. +getUnspent :: Writer -> OutPoint -> IO (Maybe Unspent) +getUnspent w op = getLayered w (getUnspentH op) (`Q.getUnspent` op) +-- | Whether a transaction is in the mempool, with the changes of the batch +-- applied. It reads the small key that lists the transaction, where +-- 'getMempoolTx' reads and decodes its whole body: a rule that only needs +-- to know asks this. +inMempool :: Writer -> TxHash -> IO Bool +inMempool w h = + H.lookup w.memory.mempoolTable h >>= \case + Just change -> return (isJust change) + Nothing -> isJust <$> (retrieveCF w.reader.db (mempoolCF w.reader.db) (MemTxKey h) :: IO (Maybe UnixTime)) + +-- | Body of a transaction in the mempool area, without its spenders, with +-- the changes of the batch applied. +getMempoolTx :: Writer -> TxHash -> IO (Maybe TxData) +getMempoolTx w h = getLayered w (\s -> H.lookup s.memTxTable h) (`M.getMempoolTx` h) + +-- | Mempool input that spends an output, with the changes of the batch +-- applied. +getMempoolSpender :: Writer -> OutPoint -> IO (Maybe Spender) +getMempoolSpender w p = getLayered w (\s -> H.lookup s.memSpenderTable p) stored + where + stored r = retrieveCF r.db (mempoolCF r.db) (MemSpenderKey p) + +-- | Mempool inputs that spend the outputs of a transaction, by output +-- index, with the changes of the batch applied. The second argument is the +-- number of outputs of the transaction: what the database has for it is +-- read with one scan, and the changes of the batch are looked up for each +-- output. +getMempoolSpenders :: Writer -> TxHash -> Int -> IO (IntMap Spender) +getMempoolSpenders w h outputs = do + stored <- M.getMempoolSpenders w.reader h + changed <- catMaybes <$> mapM change [0 .. outputs - 1] + return $ IntMap.mapMaybe id (IntMap.union (IntMap.fromList changed) (IntMap.map Just stored)) + where + change i = fmap (i,) <$> H.lookup w.memory.memSpenderTable (OutPoint h (fromIntegral i)) + +-- | The spenders of a group of outputs of a transaction, with the changes +-- of the batch applied. +spenderGroupOf :: Writer -> TxHash -> Word32 -> IO (IntMap Spender) +spenderGroupOf w h g = + H.lookup w.memory.spenderTable (h, g) >>= \case + Just m -> return m + Nothing -> + retrieveCF w.reader.db (spenderCF w.reader.db) (SpenderKey h g) <&> \case + Just (SpenderVal m) -> m + Nothing -> IntMap.empty + +-- | Note that an input of a block spends an output, in the group of +-- outputs that it belongs to. The record of the transaction that made the +-- output is not read and not written. +insertSpender :: Writer -> OutPoint -> Spender -> IO () +insertSpender w p s = do + let g = p.index `div` spenderGroup + m <- spenderGroupOf w p.hash g + H.insert w.memory.spenderTable (p.hash, g) (IntMap.insert (fromIntegral p.index) s m) + +-- | Note that no block spends an output any more. +deleteSpender :: Writer -> OutPoint -> IO () +deleteSpender w p = do + let g = p.index `div` spenderGroup + m <- spenderGroupOf w p.hash g + H.insert w.memory.spenderTable (p.hash, g) (IntMap.delete (fromIntegral p.index) m) + +-- | The input of a block that spends an output, with the changes of the +-- batch applied. +getChainSpender :: Writer -> OutPoint -> IO (Maybe Spender) +getChainSpender w p = IntMap.lookup (fromIntegral p.index) <$> spenderGroupOf w p.hash (p.index `div` spenderGroup) + +-- | The inputs of blocks that spend the outputs of a transaction, by +-- output, with the changes of the batch applied, given the number of its +-- outputs: what the database has, read with one scan, with the groups +-- that the batch changed in place of the stored ones. +getChainSpenders :: Writer -> TxHash -> Int -> IO (IntMap Spender) +getChainSpenders w h outputs = do + stored <- Q.getChainSpenders w.reader h + let groups = [0 .. (fromIntegral (max 1 outputs) - 1) `div` spenderGroup] + changed <- catMaybes <$> mapM (\g -> fmap (g,) <$> H.lookup w.memory.spenderTable (h, g)) groups + let replaced = [g | (g, _) <- changed] + kept = IntMap.filterWithKey (\i _ -> (fromIntegral i `div` spenderGroup) `notElem` replaced) stored + return (IntMap.unions (kept : map snd changed)) + -- | The mempool in the database with the changes of this batch applied, -- newest first. -getMempoolI :: (MonadIO m) => WriterT m [(UnixTime, TxHash)] -getMempoolI = - ReaderT $ \Writer {reader = db, memory = Memory {..}} -> do - stored <- runReaderT getMempool db - changes <- liftIO $ H.toList mempoolTable - let changed = HashMap.fromList changes - kept = filter (not . (`HashMap.member` changed) . snd) stored - added = [(t, h) | (h, Just t) <- changes] - return $ sortOn Down (kept <> added) +getMempool :: Writer -> IO [(UnixTime, TxHash)] +getMempool w = do + stored <- Q.getMempool w.reader + changes <- H.toList w.memory.mempoolTable + let changed = HashMap.fromList changes + kept = filter (not . (`HashMap.member` changed) . snd) stored + added = [(t, h) | (h, Just t) <- changes] + return $ sortOn Down (kept <> added) -- | Empty set of changes. newMemory :: - (MonadIO m) => Network -> Ctx -> - m Memory + IO Memory newMemory net ctx = do best <- newIORef Nothing blockTable <- liftIO H.new @@ -426,6 +653,10 @@ addressTable <- liftIO H.new outputTable <- liftIO H.new mempoolTable <- liftIO H.new + memTxTable <- liftIO H.new + memSpenderTable <- liftIO H.new + memAddrTable <- liftIO H.new + spenderTable <- liftIO H.new return Memory {..} -- | Read the best block from the changes of the batch: 'Nothing' if unchanged, @Just Nothing@ if deleted. diff --git a/src/Haskoin/Store/Fleet.hs b/src/Haskoin/Store/Fleet.hs new file mode 100644 --- /dev/null +++ b/src/Haskoin/Store/Fleet.hs @@ -0,0 +1,201 @@ +-- | +-- Module : Haskoin.Store.Fleet +-- Copyright : (c) Haskoin Developers +-- License : MIT +-- Maintainer : jprupp@protonmail.ch +-- Stability : experimental +-- Portability : POSIX +-- +-- How stores that share one Redis agree on the block that they all answer +-- from, as pure decisions. "Haskoin.Store.Fleet.Redis" carries them out. +-- This is the first part of the design in @docs\/layered-database.md@, "A +-- fleet that answers as one", written down so that it can be tested before +-- a store depends on it. +-- +-- = The problem +-- +-- Stores import the same blocks at slightly different times. Between the +-- moment the first of them has a block and the moment the last has it, the +-- same request gets different answers depending on which store a load +-- balancer picks. Making the stores commit a block together would need +-- every one of them to be there and on time, and one that stalls would hold +-- up all the others. +-- +-- = The idea: agree on the state, not on the moment +-- +-- Redis holds the /fleet tip/: the newest block that every live store has. +-- Each store imports blocks whenever it gets them, and keeps a view of its +-- database at each recent block. A request reads the fleet tip and is +-- answered from the view at that block. So every store gives the same +-- answer, and the fleet moves to a new block in one step, when the tip +-- moves, although no two stores imported it at the same time. +-- +-- = The rules +-- +-- * __A store reports its recent blocks__, newest first, under a lease that +-- it has to renew ('report'). A store that dies or hangs stops counting +-- when its lease runs out, and holds nobody up. It reports only the blocks +-- that it still has a view of: a view that was let go cannot be had again, +-- and the model test found at once what happens when the tip moves to such +-- a block. A store that is alive but stuck on old blocks would hold the +-- tip back for as long as it renews its lease, so a store stops reporting +-- when its own health checks fail. +-- +-- * __A store reports only if it has a view of the fleet tip__ ('mayReport'). +-- One that is catching up, or that just started, would otherwise pull the +-- tip back to an older block, or to one that it alone has. +-- +-- * __The tip moves to the newest block that every live store reported__ +-- ('agreed', 'move'). Any store may move it. The move is a compare and +-- set, so two stores that try at once do the same thing once. +-- +-- * __A store keeps the views of the blocks of its last report, and of the +-- tip that it read after making it__ ('keep'). The tip can only move to a +-- block that every live store reported, so a live store always has the +-- view that it is asked for. +-- +-- * __A store that does not have a view of the tip does not answer from +-- another block__ ('answer'). It was away for longer than its lease, and +-- says that it is behind until it has caught up. +-- +-- A reorganisation needs no rule of its own. The tip is a block, not a +-- height: when every live store has moved to the other branch, the newest +-- block that they all report is on it, and the tip goes there. +-- +-- The stores and the blocks can be of any type that can be compared, so +-- that the tests can run fleets of small numbers. +module Haskoin.Store.Fleet + ( -- * The state in Redis + Fleet (..), + Report (..), + Time, + empty, + + -- * Reporting + mayReport, + report, + live, + + -- * Moving the tip + agreed, + Move (..), + move, + + -- * In a store + keep, + Answer (..), + answer, + ) +where + +import Data.List (find) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Word (Word64) + +-- | A moment, in any unit that the stores share. In Redis it is the clock +-- of Redis, so that the stores do not have to agree on theirs. +type Time = Word64 + +-- | What a store last said about itself. +data Report b = Report + { -- | the blocks of its main chain that it has views of, newest first + recent :: ![b], + -- | the moment its lease runs out + expires :: !Time + } + deriving (Eq, Show) + +-- | What Redis holds for a fleet of stores of type @s@ with blocks of type +-- @b@. +data Fleet s b = Fleet + { -- | the block that every store answers from, once there is one + tip :: !(Maybe b), + -- | the last report of each store, live or not + reports :: !(Map s (Report b)) + } + deriving (Eq, Show) + +-- | A fleet that no store has joined. +empty :: Fleet s b +empty = Fleet {tip = Nothing, reports = Map.empty} + +-- | The reports whose lease has not run out. +live :: Time -> Fleet s b -> Map s (Report b) +live now fleet = Map.filter ((> now) . (.expires)) fleet.reports + +-- | Whether a store may report, given a test for the blocks that it has a +-- view of. It may when it has a view of the tip. It also may when there is +-- no tip yet, or when no other store is live: then there is nobody to +-- disagree with, and a fleet whose stores were all away has to be able to +-- start again. +mayReport :: (Ord s) => Time -> s -> (b -> Bool) -> Fleet s b -> Bool +mayReport now store has fleet = + maybe True has fleet.tip || Map.null (Map.delete store (live now fleet)) + +-- | Note the recent blocks of a store, newest first, under a lease of some +-- length. The store must have checked 'mayReport' against the same state: +-- in Redis the two are one script. +report :: (Ord s) => Time -> Time -> s -> [b] -> Fleet s b -> Fleet s b +report now lease store blocks fleet = + fleet {reports = Map.insert store Report {recent = blocks, expires = now + lease} fleet.reports} + +-- | The newest block that every live store reported, if there is one, and +-- if any store is live. Stores report their blocks newest first, so it is +-- the first block of any one report that all the others have. +agreed :: (Eq b) => Time -> Fleet s b -> Maybe b +agreed now fleet = case Map.elems (live now fleet) of + [] -> Nothing + first : others -> find (\b -> all (elem b . (.recent)) others) first.recent + +-- | What became of an attempt to move the tip. +data Move s b + = -- | the tip is now this block + Moved !(Fleet s b) + | -- | the tip is already where the live stores agree, or they agree on + -- nothing + Stays + | -- | the tip was not the one that the store expected: another store moved + -- it first + Raced + deriving (Eq, Show) + +-- | Move the tip to the block that the live stores agree on, given the tip +-- that the caller saw. The caller says what it saw because it also changes +-- the shared mempool for the blocks between the two tips, and that change +-- is right for one starting point only. +move :: (Eq b) => Time -> Maybe b -> Fleet s b -> Move s b +move now seen fleet + | seen /= fleet.tip = Raced + | otherwise = case agreed now fleet of + Just b | Just b /= fleet.tip -> Moved fleet {tip = Just b} + _ -> Stays + +-- | The blocks whose views a store must keep: those of its last report, +-- and the tip that it read after that report was made. It may let go of +-- every other view. +-- +-- The order matters. A tip read before the report could have moved, in +-- between, to a block that only the earlier report had. +keep :: [b] -> Maybe b -> [b] +keep reported seen = maybe reported (: reported) seen + +-- | What a store answers a request from. +data Answer b + = -- | the view at this block, as every other store does + At !b + | -- | its own best block: there is no fleet tip yet + Alone + | -- | nothing: it has no view of the fleet tip, so any answer would differ + -- from those of the other stores + Behind + deriving (Eq, Show) + +-- | What a store answers a request from, given a test for the blocks that +-- it has a view of and the fleet as the request found it. +answer :: (b -> Bool) -> Fleet s b -> Answer b +answer has fleet = case fleet.tip of + Nothing -> Alone + Just b + | has b -> At b + | otherwise -> Behind diff --git a/src/Haskoin/Store/Fleet/Member.hs b/src/Haskoin/Store/Fleet/Member.hs new file mode 100644 --- /dev/null +++ b/src/Haskoin/Store/Fleet/Member.hs @@ -0,0 +1,1078 @@ +{-# LANGUAGE RecordWildCards #-} + +-- | +-- Module : Haskoin.Store.Fleet.Member +-- Copyright : (c) Haskoin Developers +-- License : MIT +-- Maintainer : jprupp@protonmail.ch +-- Stability : experimental +-- Portability : POSIX +-- +-- A store as a member of a fleet: what it does, with its own database and +-- the Redis that the fleet shares, so that every store of the fleet gives +-- the same answer to the same request. The rules are in +-- "Haskoin.Store.Fleet" and "Haskoin.Store.Fleet.Pool", Redis carries them +-- out through "Haskoin.Store.Fleet.Redis", and the reasons are in "A fleet +-- that answers as one" in @docs\/layered-database.md@. +-- +-- = What a member does +-- +-- * __It keeps a view of its database at each recent block__ ('noteBest'), +-- taken by the block store right after it imports or reverts a block, +-- and lets go of those that the rules no longer ask for. +-- +-- * __It reports those blocks under a lease, and moves the fleet tip__ +-- ('memberTick') to the newest block that every live store reported, +-- telling the pool what the blocks in between did ('changeBetween'): +-- which transactions they confirmed and which outputs they spent, and +-- across a reorganisation which transactions come back. +-- +-- * __It offers its mempool to the shared pool__ ('offerMempool'), each +-- transaction with whether its inputs are unspent in the store's view at +-- the fleet tip, so that the pool only takes what is valid there. +-- +-- * __It answers from the view at the fleet tip with the pool on top__ +-- ('answering', 'redisPool'), or says that it is behind when it has no +-- view of the tip. +-- +-- * __It keeps the fleet's cache of extended public keys__ +-- ("Haskoin.Store.Fleet.XPub"): it answers the queries about a key from +-- it when the cache has the key ('answeringCached'), builds the entries +-- that requests missed ('memberCacheLoop'), brings the cache to the new +-- block when it moves the tip, and empties a cache that was left behind +-- ('syncCache'). +-- +-- = Why the member does not withdraw what it deletes +-- +-- A store deletes a transaction from its own mempool when it replaces it, +-- when a block confirms a conflicting one, and when it is too old. The +-- first reaches the pool with the offer of the replacement, which names +-- what it replaces. The second reaches it when the tip moves to that block. +-- The third is done on the pool itself, by its own times ('expirePool'), so +-- that the stores do not have to agree on when each of them first saw a +-- transaction. A store that simply does not have a transaction says +-- nothing about it: another store has it. +module Haskoin.Store.Fleet.Member + ( -- * A member + Member (..), + MemberConfig (..), + newMember, + noteBest, + memberForget, + memberTick, + memberLoop, + memberAlive, + memberEvents, + + -- * Answering + Standing (..), + answering, + memberTip, + answeringAt, + answeringCached, + TipMoved (..), + redisPool, + + -- * The cache of extended public keys + CacheMetrics (..), + memberCacheLoop, + wantCached, + syncCache, + + -- * The parts of a tick + report, + moveTip, + Between (..), + blocksBetween, + changeBetween, + offerMempool, + expirePool, + poolTx, + ) +where + +import Control.Exception (Exception, throwIO) +import Control.Monad (filterM, forM, forM_, unless, void, when) +import Data.ByteString (ByteString) +import Data.ByteString qualified as B +import Data.ByteString.Char8 qualified as C +import Data.Either (rights) +import Data.Functor ((<&>)) +import Data.HashMap.Strict (HashMap) +import Data.HashMap.Strict qualified as HashMap +import Data.HashSet (HashSet) +import Data.HashSet qualified as HashSet +import Data.IntMap.Strict qualified as IntMap +import Data.List (nub, sortOn) +import Data.Map.Strict qualified as Map +import Data.Maybe (catMaybes, fromMaybe, isJust, mapMaybe) +import Data.Serialize (Serialize, decode, encode) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Encoding (decodeUtf8) +import Data.Time.Clock.POSIX (getPOSIXTime) +import Data.Word (Word64) +import Database.Redis qualified as R +import Haskoin + ( BlockHash, + BlockHeader (..), + Ctx, + Network (..), + OutPoint (..), + Tx (..), + TxHash, + TxIn (..), + blockHashToHex, + headerHash, + nullOutPoint, + txHash, + ) +import Haskoin.Node (LogLevel (..)) +import Haskoin.Store.Common (Limits (..), StoreRead (..)) +import Haskoin.Store.Data + ( Balance (..), + BlockData (..), + BlockRef (..), + Spender (..), + TxData (..), + UnixTime, + Unspent (..), + XPubBal (..), + XPubSpec, + nullBalance, + ) +import Haskoin.Store.Database.Mempool qualified as M +import Haskoin.Store.Database.Query qualified as Q +import Haskoin.Store.Database.Query.Layered qualified as L +import Haskoin.Store.Database.Query.Pooled (PoolReads (..), pageStart, pooledRead) +import Haskoin.Store.Database.Reader (DatabaseReader (..), txCF) +import Haskoin.Store.Database.Types + ( MemAddrKey (..), + MemAddrVal (..), + MemSummary (..), + TxKey (..), + ) +import Haskoin.Store.Database.Views (Views, heldViews, keepViews, newViews, takeView, withViewAt) +import Haskoin.Store.Fleet qualified as F +import Haskoin.Store.Fleet.Redis +import Haskoin.Store.Fleet.XPub +import System.Metrics.StatsD + ( StatCounter, + StatGauge, + StatTiming, + Stats, + addTiming, + incrementCounter, + newStatCounter, + newStatGauge, + newStatTiming, + setGauge, + ) +import UnliftIO + ( TVar, + atomically, + handle, + handleAny, + modifyIORef', + modifyTVar', + newIORef, + newTVarIO, + readIORef, + readTVar, + readTVarIO, + retrySTM, + stateTVar, + timeout, + writeIORef, + writeTVar, + ) + +-- | How a store takes part in a fleet. +data MemberConfig = MemberConfig + { -- | what every key of the fleet in Redis starts with + prefix :: !ByteString, + -- | the name of this store, which no other store of the fleet has + name :: !ByteString, + -- | how long a report counts for, in milliseconds. A store that stops + -- reporting holds the tip back for this long at most. + lease :: !Word64, + -- | how many recent blocks to keep views of and report. With more, the + -- stores find a block in common sooner when they import several at + -- once; each view keeps the files that it reads from being deleted. + depth :: !Int, + -- | seconds after which a transaction leaves the pool unconfirmed, or 0 + -- for never + expiry :: !Word64, + -- | how many extended public keys the fleet's cache of them may hold + -- ("Haskoin.Store.Fleet.XPub"), the least recently used going first, or + -- 0 not to use the cache + cacheMax :: !Int, + -- | cache a key that has at least this many used addresses + cacheMinAddrs :: !Int, + -- | or at least this many transactions in its addresses + cacheMinTxs :: !Int, + -- | StatsD client, to report what the cache of extended public keys + -- does, as t'CacheMetrics' lists + stats :: !(Maybe Stats), + -- | where to say what a log should have: that the cache was emptied + -- and why, as information, and each entry built and each move of the + -- cache, for debugging + note :: !(LogLevel -> Text -> IO ()) + } + +-- | StatsD metrics of the fleet's cache of extended public keys, as this +-- store sees it. They have the names of those of "Haskoin.Store.Cache" +-- under @fleet@, so that a dashboard reads both alike. +data CacheMetrics = CacheMetrics + { -- | requests about a key whose balances the cache gave + -- (@fleet.cache.hits@) + hits :: !StatCounter, + -- | requests about a key that the database answered: the cache did + -- not have the key, had it with other addresses, or was not at the + -- fleet tip (@fleet.cache.misses@) + misses :: !StatCounter, + -- | entries that this store built or added addresses to + -- (@fleet.cache.builds@) + builds :: !StatCounter, + -- | builds that this store gave up, because the tip moved or another + -- store wrote the entry (@fleet.cache.abandoned@) + abandoned :: !StatCounter, + -- | entries that this store deleted for being the least recently used + -- (@fleet.cache.evictions@) + evictions :: !StatCounter, + -- | times that this store emptied the cache (@fleet.cache.emptied@) + emptied :: !StatCounter, + -- | milliseconds to build an entry (@fleet.cache.build@) + buildTime :: !StatTiming, + -- | entries in the cache, one for each extended public key, whichever + -- store built them (@fleet.cache.xpubs@) + xpubs :: !StatGauge, + -- | addresses that those entries have between them + -- (@fleet.cache.addresses@) + addresses :: !StatGauge + } + +-- | Register the metrics of the cache. +newCacheMetrics :: Stats -> IO CacheMetrics +newCacheMetrics s = do + hits <- c "hits" + misses <- c "misses" + builds <- c "builds" + abandoned <- c "abandoned" + evictions <- c "evictions" + emptied <- c "emptied" + buildTime <- newStatTiming s "fleet.cache.build" 10 + xpubs <- newStatGauge s "fleet.cache.xpubs" 0 + addresses <- newStatGauge s "fleet.cache.addresses" 0 + return CacheMetrics {..} + where + c x = newStatCounter s ("fleet.cache." <> x) 10 + +-- | Add to a counter of the cache, if metrics are reported. +tally :: Member -> (CacheMetrics -> StatCounter) -> Int -> IO () +tally m which n = forM_ m.metrics (\x -> incrementCounter (which x) n) + +-- | A store that is a member of a fleet. +data Member = Member + { config :: !MemberConfig, + redis :: !R.Connection, + keys :: !FleetKeys, + db :: !DatabaseReader, + -- | the database as it was at each recent block + views :: !(Views BlockHash), + -- | the blocks that views were taken of, newest first + recent :: !(TVar [BlockHash]), + -- | the blocks of the last report that was taken + reported :: !(TVar [BlockHash]), + -- | the fleet tip, read after that report + tip :: !(TVar (Maybe BlockHash)), + -- | the transactions of the store's mempool that the pool has + offered :: !(TVar (HashSet TxHash)), + -- | those that it refused, or that there was no time to offer, with + -- the times at which they entered the mempool: they are offered again + waiting :: !(TVar (HashMap TxHash UnixTime)), + -- | how many times the mempool was offered, and at which tip last + rounds :: !(TVar Int), + offeredAt :: !(TVar (Maybe BlockHash)), + -- | whether the best block changed since the mempool was last offered + changed :: !(TVar Bool), + -- | whether the store's own health checks pass. While they do not, the + -- member does nothing, so that its lease runs out and a store that is + -- stuck does not hold the fleet back. + healthy :: !(TVar Bool), + -- | the extended public keys that requests asked about and the cache + -- did not have, by their names in Redis: 'memberCacheLoop' builds + -- their entries + wanted :: !(TVar (HashMap ByteString XPubSpec)), + -- | the fleet tip at which the cache was found at another block, at + -- the last turn + lagging :: !(TVar (Maybe ByteString)), + -- | the metrics of the cache, if the configuration has a StatsD client + metrics :: !(Maybe CacheMetrics), + -- | transactions that the store deleted from its mempool since it + -- started, up to a hundred thousand. The database keeps nothing of + -- them, and the rule for conflicts in the pool asks about them + -- ('offerMempool'). + gone :: !(TVar (HashSet TxHash)) + } + +-- | A member with no views yet, on a connection to the Redis of the fleet. +newMember :: MemberConfig -> R.Connection -> DatabaseReader -> IO Member +newMember config redis db = do + views <- newViews db + recent <- newTVarIO [] + reported <- newTVarIO [] + tip <- newTVarIO Nothing + offered <- newTVarIO HashSet.empty + waiting <- newTVarIO HashMap.empty + rounds <- newTVarIO 0 + offeredAt <- newTVarIO Nothing + changed <- newTVarIO True + healthy <- newTVarIO True + wanted <- newTVarIO HashMap.empty + lagging <- newTVarIO Nothing + metrics <- mapM newCacheMetrics config.stats + gone <- newTVarIO HashSet.empty + return Member {keys = fleetKeys config.prefix 32, ..} + +-- | Take a view of the database for its best block. The block store calls +-- this right after it imports or reverts a block, and when it starts, +-- before it writes anything else: the view is then of that block and of +-- nothing more. +noteBest :: Member -> BlockHash -> IO () +noteBest m block = do + takeView m.views block + atomically $ do + modifyTVar' m.recent $ \blocks -> take m.config.depth (block : filter (/= block) blocks) + writeTVar m.changed True + prune m + +-- | Note that transactions left the store's mempool unconfirmed. The store +-- calls this when it deletes them. The member forgets that it offered them: +-- one that comes back, as a transaction does that is sent again after it +-- was replaced, is then offered again, and takes the place of what replaced +-- it if this store's rules say so. +memberForget :: Member -> [TxHash] -> IO () +memberForget m hs = atomically $ do + modifyTVar' m.offered (\have -> foldr HashSet.delete have hs) + modifyTVar' m.waiting (\held -> foldr HashMap.delete held hs) + modifyTVar' m.gone $ \seen -> + let more = foldr HashSet.insert seen hs + in if HashSet.size more > 100000 then HashSet.fromList hs else more + +-- | Let go of the views that the rules do not ask for: all but those of +-- the recent blocks, of the last report, and of the tip read after it. +prune :: Member -> IO () +prune m = do + recent <- readTVarIO m.recent + reported <- readTVarIO m.reported + tip <- readTVarIO m.tip + keepViews m.views (nub (F.keep (recent <> reported) tip)) + +-- | Whether Redis answers a ping within two seconds. +memberAlive :: Member -> IO Bool +memberAlive m = + handleAny (\_ -> return False) $ + timeout 2000000 (R.runRedis m.redis R.ping) <&> \case + Just (Right _) -> True + _ -> False + +-- | One round of what a member does: report, move the tip if the stores +-- agree on another block, offer what the pool does not have of the store's +-- mempool, and let go of old views. Call it every second or two, and when +-- the best block changes. A store whose own health checks fail must not +-- call it: its lease then runs out, and the fleet goes on without it. +memberTick :: Member -> IO () +memberTick m = do + report m + moved <- moveTip m + -- the tip is read after the report, as the rule of 'F.keep' asks + tip <- fmap decoded <$> fleetTip m.redis m.keys + atomically (writeTVar m.tip (fromMaybe Nothing tip)) + prune m + syncCache m + unless moved (expirePool m) + offerMempool m + where + decoded = either (const Nothing) Just . decode + +-- | Take a turn as a member every two seconds, and at once when an action +-- that waits for the next best block returns, for as long as the store's +-- health checks pass. A turn that fails, as when Redis is away, is told to +-- a function and tried again at the next. +memberLoop :: Member -> IO () -> (String -> IO ()) -> IO a +memberLoop m nextBlock complain = go + where + go = do + void (timeout 2000000 nextBlock) + well <- readTVarIO m.healthy + when well (handleAny (complain . show) (memberTick m)) + go + +-- | Hear what happens to the fleet, for as long as the store runs: each +-- move of the tip and each transaction that enters or leaves the pool is +-- told to a function, in the order in which Redis has them. Every store of +-- the fleet hears the same, which is what its clients are told +-- ('FleetEvent'). +-- +-- The telling starts from now, or from the oldest event that Redis keeps: +-- the second is for a listener that wants to hold the same history as the +-- other stores whenever it started, as the log of events of the web server +-- does. When Redis cannot be read a function is told why, and listening +-- goes on from the last event heard, so nothing is left out unless Redis +-- dropped it meanwhile. +memberEvents :: Member -> Bool -> (FleetEvent -> IO ()) -> (String -> IO ()) -> IO a +memberEvents m whole tell complain = newIORef (if whole then Just "0-0" else Nothing) >>= start + where + start at = do + handleAny (complain . show) $ do + from <- readIORef at >>= maybe (fleetEventsEnd m.redis m.keys) return + writeIORef at (Just from) + listen at from + void (timeout 1000000 (atomically retrySTM) :: IO (Maybe ())) + start at + listen at from = do + events <- fleetEventsAfter m.redis m.keys from 1000 + mapM_ (tell . snd) events + let next = foldl (\_ (place, _) -> place) from events + writeIORef at (Just next) + listen at next + +-- | Report the blocks of the main chain that the store has views of, newest +-- first. +report :: Member -> IO () +report m = do + held <- heldViews m.views + recent <- readTVarIO m.recent + blocks <- filterM main (filter (`elem` held) recent) + taken <- fleetReport m.redis m.keys Nothing m.config.lease m.config.name (map encode blocks) (map encode held) + atomically (writeTVar m.reported (if taken then blocks else [])) + where + main h = maybe False (.main) <$> Q.getBlock m.db h + +-- | Move the fleet tip to the block that the live stores agree on, if it is +-- another one, with what the blocks in between did to the pool. Says +-- whether it moved. When this store cannot say what they did, the pool is +-- emptied, which Redis allows only to a store that is alone. +moveTip :: Member -> IO Bool +moveTip m = do + seen <- fleetTip m.redis m.keys + leases <- fleetLive m.redis m.keys + recents <- redis' (R.hgetall m.keys.recent) + now <- redis' R.time <&> \(s, us) -> fromIntegral (s * 1000 + us `div` 1000) + let reports = + Map.fromList + [ (store, F.Report {recent = chunks blocks, expires}) + | (store, expires) <- leases, + Just blocks <- [lookup store recents] + ] + fleet = F.Fleet {tip = seen, reports} + case F.agreed now fleet of + Just target | Just target /= seen -> do + between <- case (traverse decode seen, decode target) of + (Right from, Right to) -> blocksBetween m.db from to + _ -> return Nothing + let path = maybe [] (map encode . (.path)) between + fleetAdvance m.redis m.keys 32 Nothing seen target ((.pool) <$> between) path >>= \case + MovedTo _ -> advanceCache m seen target between >> return True + _ -> return False + _ -> return False + where + redis' :: R.Redis (Either R.Reply a) -> IO a + redis' f = R.runRedis m.redis f >>= either (fail . ("Redis error: " <>) . show) return + chunks bytes + | B.null bytes = [] + | otherwise = B.take 32 bytes : chunks (B.drop 32 bytes) + +-- | The most blocks that 'changeBetween' goes through on either side of a +-- fork. Beyond that, a store that is alone starts the pool again, which +-- costs the stores an offer of their mempools; going through a thousand +-- blocks would cost a read of every transaction in them. +farthest :: Int +farthest = 50 + +-- | What the blocks between two tips did, as far as the pool is concerned, +-- read from the database as it is now: the transactions of the blocks that +-- lead from the first tip, or from the genesis block, to where the main +-- chain forked from it, which come back or are gone, and those of the +-- blocks of the main chain from there to the second tip, which are +-- confirmed, with the outputs that they spend. +-- +-- Without a first tip there was no pool, and the blocks did nothing to it. +-- 'Nothing' if the database does not have one of the tips, if the second +-- is not on its main chain, or if the way is longer than 'farthest' +-- blocks on either side. +changeBetween :: DatabaseReader -> Maybe BlockHash -> BlockHash -> IO (Maybe PoolChange) +changeBetween db from to = fmap (.pool) <$> blocksBetween db from to + +-- | What the blocks between two tips did. +data Between = Between + { -- | what they did to the pool + pool :: !PoolChange, + -- | the transactions of the blocks of the main chain from where it + -- left the way to the first tip, up to the second, in their order + added :: ![TxData], + -- | whether blocks of the way to the first tip were abandoned + reorganised :: !Bool, + -- | those blocks of the main chain, oldest first, the second tip last: + -- what the fleet tells its clients that the tip moved through + path :: ![BlockHash] + } + +-- | 'changeBetween', with the transactions that the new blocks confirm, +-- which is what the cache of extended public keys is brought to the new +-- tip with ('advanceCache'). +blocksBetween :: DatabaseReader -> Maybe BlockHash -> BlockHash -> IO (Maybe Between) +blocksBetween db from to = L.withView db $ \view -> do + let r = L.viewReader view + -- the blocks from one that is not on the main chain back to it + back :: Int -> BlockHash -> IO (Maybe ([BlockData], BlockData)) + back n h + | n > farthest = return Nothing + | otherwise = + Q.getBlock r h >>= \case + Nothing -> return Nothing + Just bd + | bd.main -> return (Just ([], bd)) + | otherwise -> fmap (\(bs, fork) -> (bd : bs, fork)) <$> back (n + 1) bd.header.prev + -- the blocks of the main chain from a block down to above a height + down :: Int -> BlockData -> BlockData -> IO (Maybe [BlockData]) + down n fork bd + | n > farthest = return Nothing + | bd.height <= fork.height = return (if bd.header == fork.header then Just [] else Nothing) + | otherwise = + Q.getBlock r bd.header.prev >>= \case + Nothing -> return Nothing + Just parent -> fmap (bd :) <$> down (n + 1) fork parent + target <- Q.getBlock r to + left <- case from of + Just h -> back 0 h + -- without a tip there was no pool, and nothing for the blocks to do + Nothing -> return (fmap ([],) target) + case (target, left) of + (Just bd, Just (abandoned, fork)) + | bd.main -> + down 0 fork bd >>= \case + Nothing -> return Nothing + Just added -> do + old <- concat <$> mapM (bodies view) (reverse abandoned) + new <- concat <$> mapM (confirmedBy r) (reverse added) + let pool = + PoolChange + { returned = [poolTx r.net r.ctx td | (_, Just td) <- old, not (coinbase td)], + gone = [encode h | (h, found) <- old, maybe True coinbase found], + confirmed = map (encode . txHash . (.tx)) new, + spent = [encode i.outpoint | td <- new, i <- td.tx.inputs, i.outpoint /= nullOutPoint] + } + let path = map (headerHash . (.header)) (reverse added) + return (Just Between {pool, added = new, reorganised = not (null abandoned), path}) + _ -> return Nothing + where + -- the transactions of an abandoned block, each with what the store has + -- of it now, if it still has it and did not delete it + bodies view bd = do + found <- L.getManyTxData view bd.txs + return [(h, found' >>= live) | (h, found') <- zip bd.txs found] + live td = if td.deleted then Nothing else Just td + confirmedBy :: DatabaseReader -> BlockData -> IO [TxData] + confirmedBy r bd = catMaybes <$> Q.retrieveManyCF r.db (txCF r.db) (map TxKey bd.txs) + coinbase td = any ((== nullOutPoint) . (.outpoint)) td.tx.inputs + +-- | A transaction as the pool keeps it: its body without spenders, and +-- what it does at each address, as "Haskoin.Store.Database.Mempool" works +-- them out for the store's own mempool area. +poolTx :: Network -> Ctx -> TxData -> PoolTx +poolTx net ctx td = + PoolTx + { txid = encode records.txid, + time, + inputs = [encode op | (op, _) <- records.spends], + body = encode records.body, + signals = net.replaceByFee && any ((< 0xffffffff - 1) . (.sequence)) td.tx.inputs, + entries = mapMaybe entry records.addresses + } + where + time = case td.block of + MemRef t -> t + BlockRef {} -> 0 + records = M.mempoolRecords net ctx time td + entry = \case + (MemAddrTxKey a _ _, _) -> Just (PoolTouches (encode a)) + (MemAddrSpentKey a p, MemAddrSpentVal v) -> Just (PoolSpends (encode a) (encode p) v) + (MemAddrOutKey a _ p, MemAddrOutVal v s) -> Just (PoolPays (encode a) (encode p) v s) + _ -> Nothing + +-- | Offer to the pool the transactions of the store's mempool that it does +-- not have, oldest first, so that each comes after those that it spends +-- from. A store without a view of the fleet tip offers nothing: it cannot +-- say what is unspent there. +-- +-- A transaction that the pool refuses is offered again at the next round: +-- its parents may not be there yet, or the tip may have moved. One that +-- conflicts with transactions of the pool takes their place when this +-- store deleted every one of them by its own rules, as it does when it +-- replaces a transaction, and otherwise stays out: the first of two that +-- spend the same output stays. +-- +-- = Reading no more of the mempool than is new +-- +-- A mempool has tens of thousands of transactions and a round comes every +-- two seconds, so a round does not read the whole list. It reads the list +-- from the newest, a page at a time, until a page has nothing that it does +-- not know, and offers what it found with what is waiting from earlier +-- rounds. The whole list is read when the tip has moved or the store's best +-- block has changed, since a block or a reorganisation changes the mempool +-- anywhere, and every 'wholeEvery' rounds, for whatever the short way +-- missed. What the store deletes in between it tells the member +-- ('memberForget'). A round offers 'mostOffers' +-- transactions at most and leaves the rest waiting, so that a store with a +-- large mempool to offer still reports in time to keep its lease. +offerMempool :: Member -> IO () +offerMempool m = + readTVarIO m.tip >>= \case + Nothing -> return () + Just tip -> void . withViewAt m.views tip $ \at -> do + before <- readTVarIO m.offeredAt + (n, dirty) <- atomically $ do + writeTVar m.offeredAt (Just tip) + (,) <$> stateTVar m.rounds (\k -> (k, k + 1)) <*> stateTVar m.changed (,False) + todo <- if dirty || before /= Just tip || n `mod` wholeEvery == 0 then everything else newest + let (now, later) = splitAt mostOffers (sortOn fst todo) + atomically (modifyTVar' m.waiting (HashMap.union (HashMap.fromList [(h, time) | (time, h) <- later]))) + go at tip now + where + -- all of the mempool that the pool does not have, forgetting what has + -- left the mempool + everything = do + mempool <- Q.getMempool m.db + have <- readTVarIO m.offered + let kept = HashSet.intersection have (HashSet.fromList (map snd mempool)) + atomically (writeTVar m.offered kept >> writeTVar m.waiting HashMap.empty) + return [(time, h) | (time, h) <- mempool, not (HashSet.member h kept)] + -- the newest of the mempool that this member has not seen, and what is + -- waiting + newest = do + have <- readTVarIO m.offered + held <- readTVarIO m.waiting + let known h = HashSet.member h have || HashMap.member h held + scan offset = do + page <- Q.getMempoolPage m.db Limits {limit = pageSize, offset, start = Nothing} + let fresh = filter (not . known . snd) page + if null fresh || length page < fromIntegral pageSize + then return fresh + else (fresh <>) <$> scan (offset + pageSize) + found <- scan 0 + return (found <> [(time, h) | (h, time) <- HashMap.toList held]) + pageSize = 256 + go _ _ [] = return () + go at tip ((time, h) : rest) = + M.getMempoolTx m.db h >>= \case + Nothing -> forget h >> go at tip rest + Just td -> do + let tx = poolTx m.db.net m.db.ctx td + unspent <- forM [i.outpoint | i <- td.tx.inputs, i.outpoint /= nullOutPoint] $ \p -> + isJust <$> Q.getUnspent at p + let offer = poolOffer m.redis m.keys 32 (Just (encode tip)) tx unspent + done = atomically $ do + modifyTVar' m.offered (HashSet.insert h) + modifyTVar' m.waiting (HashMap.delete h) + wait = atomically (modifyTVar' m.waiting (HashMap.insert h time)) + offer [] >>= \case + Taken -> done >> go at tip rest + Known -> done >> go at tip rest + Orphan _ -> wait >> go at tip rest + -- the tip moved: the next round reads the whole mempool + Late -> return () + Conflict rivals -> do + mine <- mapM deletedHere rivals + if and mine + then + offer rivals >>= \case + Taken -> done + _ -> wait + else wait + go at tip rest + forget h = atomically (modifyTVar' m.waiting (HashMap.delete h)) + deletedHere rival = case decode rival of + Left _ -> return False + -- it deleted it, and has not taken it back since. A store that was + -- started again does not remember, and leaves the conflict as it + -- is: the first of the two stays in the pool. + Right h -> do + deleted <- HashSet.member h <$> readTVarIO m.gone + back <- isJust <$> M.getMempoolTx m.db h + return (deleted && not back) + +-- | How many rounds of offers go by between two that read the whole +-- mempool: five minutes of them. +wholeEvery :: Int +wholeEvery = 150 + +-- | The most transactions that one round offers. An offer takes a tenth of +-- a millisecond or two, so this is well under the two seconds of a round. +mostOffers :: Int +mostOffers = 2000 + +-- | Take out of the pool the transactions that entered a mempool longer +-- ago than the configuration allows, with what spends them. +expirePool :: Member -> IO () +expirePool m = when (m.config.expiry > 0) $ do + (now, _) <- R.runRedis m.redis R.time >>= either (fail . show) return + let before = fromIntegral now - fromIntegral m.config.expiry :: Double + old <- + R.runRedis m.redis (R.zrangebyscoreLimit (m.keys.prefix <> "pool:time") 0 before 0 1000) + >>= either (fail . show) return + unless (null old) (void (poolWithdraw m.redis m.keys 32 old)) + +-- | Where a store stands when a request comes. +data Standing a + = -- | the request was answered from the view at the fleet tip + Answered !a + | -- | there is no fleet tip yet: the store answers by itself + Alone + | -- | the store has no view of the fleet tip, so any answer of its own + -- would differ from those of the other stores + Behind + +-- | What a read of the pool throws when the fleet tip is no longer the +-- block that the request answers from. The request is then answered again, +-- from the new tip. +data TipMoved = TipMoved + deriving (Show) + +instance Exception TipMoved + +-- | Answer a request as a member of a fleet: read the fleet tip, and run +-- an action with the database as it was at that block and the pool as it is +-- at that tip. The action must do all its reading before it returns. +answering :: Member -> (DatabaseReader -> PoolReads -> IO a) -> IO (Standing a) +answering m action = + memberTip m >>= \case + Nothing -> return Alone + Just tip -> maybe Behind Answered <$> answeringAt m tip (\r pool _ -> action r pool) + +-- | The fleet tip as Redis has it now, if there is one. +memberTip :: Member -> IO (Maybe ByteString) +memberTip m = fleetTip m.redis m.keys + +-- | Run an action with the database as it was at a block that is taken to +-- be the fleet tip, and the pool as it is at that tip, or give 'Nothing' if +-- the store has no view of that block. The action must do all its reading +-- before it returns. +-- +-- The block need not be the tip any more: it can be the one that the +-- member read at its last turn, which saves a request the round trip of +-- asking. Every read of the pool checks it and throws v'TipMoved' if the tip +-- is another one. The action is also given a check to run when it has what +-- it needs: it asks Redis for the tip if no read of the pool has done so, +-- and throws the same. An answer that passed either is one that every +-- store of the fleet gave at that moment. +answeringAt :: Member -> ByteString -> (DatabaseReader -> PoolReads -> IO () -> IO a) -> IO (Maybe a) +answeringAt m tip action = answeringWith m tip (\r pool _ confirm -> action r pool confirm) + +-- | 'answeringAt', for an action that reads Redis by other ways than the +-- pool too: it is also given what to run after each such read that found +-- the tip where it should be. +answeringWith :: Member -> ByteString -> (DatabaseReader -> PoolReads -> IO () -> IO () -> IO a) -> IO (Maybe a) +answeringWith m tip action = case decode tip of + Left _ -> return Nothing + Right block -> withViewAt m.views block $ \r -> do + checked <- newIORef False + let confirm = + readIORef checked >>= \case + True -> return () + False -> do + now <- memberTip m + if now == Just tip then writeIORef checked True else throwIO TipMoved + found = writeIORef checked True + action r (redisPool m.redis m.keys tip found) found confirm + +-- | 'answeringAt' with the queries ready: those of +-- "Haskoin.Store.Database.Query.Pooled" for the view and the pool, and +-- the same with the cache of extended public keys in front +-- ('cachedRead'), which is what requests are answered with unless they +-- ask not to be. +answeringCached :: Member -> ByteString -> (StoreRead -> StoreRead -> IO () -> IO a) -> IO (Maybe a) +answeringCached m tip action = answeringWith m tip $ \r pool found confirm -> do + cached <- cachedRead m tip r pool found + action (pooledRead r pool) cached confirm + +------------------------------------------------------------------------------- +-- The cache of extended public keys +------------------------------------------------------------------------------- + +-- | The queries of a request with the fleet's cache of extended public +-- keys in front of those about them: given the tip that the request +-- answers from, the view at that block, the pool, and what to run after a +-- read that found the tip where it should be. +-- +-- The balances of a key come from the cache if it has the key with the +-- addresses that it has now. The other three queries about a key are given +-- its balances by the caller, and are answered from the cache when this +-- same request got them there: the cache is then asked for an entry with +-- as many addresses, so that an entry that changed in between is not +-- used. Whatever the cache does not answer the database does, and a key +-- that it did not have is put down to be built ('wantCached'). A read that +-- finds the tip moved throws v'TipMoved', like those of the pool. +cachedRead :: Member -> ByteString -> DatabaseReader -> PoolReads -> IO () -> IO StoreRead +cachedRead m tip r pool found + | m.config.cacheMax <= 0 = return base + | otherwise = do + seen <- newIORef HashMap.empty + let hit :: Cached a -> IO (Maybe a) + hit = \case + Hit x -> Just x <$ found + Miss -> return Nothing + Moved -> throwIO TipMoved + entryOf x = HashMap.lookup (xpubId x) <$> readIORef seen + -- from the cache if this request has the entry of the key, and + -- from where the page starts if it has a start + paged :: XPubSpec -> Limits -> IO [a] -> (Entry -> L.From -> IO (Cached [a])) -> IO [a] + paged x limits direct cached = + entryOf x >>= \case + Nothing -> direct + Just e -> + pageStart r pool limits.start >>= \case + Nothing -> return [] + Just from -> cached e from >>= hit >>= maybe direct return + return + base + { xPubBals = \x -> do + now <- milliseconds + cachedEntry m.redis m.keys tip r.initGap r.maxGap now x >>= hit >>= \case + Just e -> do + tally m (.hits) 1 + e.balances <$ modifyIORef' seen (HashMap.insert (xpubId x) e) + Nothing -> do + tally m (.misses) 1 + bals <- base.xPubBals x + wantCached m x bals + return bals, + xPubTxs = \x bals limits -> + paged x limits (base.xPubTxs x bals limits) $ \e from -> + cachedTxs m.redis m.keys tip x e.sizes from limits, + xPubUnspents = \x bals limits -> + paged x limits (base.xPubUnspents x bals limits) $ \e from -> + cachedUnspents m.redis m.keys tip x e from limits, + xPubTxCount = \x bals -> + entryOf x >>= \case + Nothing -> base.xPubTxCount x bals + Just e -> + cachedCount m.redis m.keys tip x e.sizes >>= hit >>= maybe (base.xPubTxCount x bals) return + } + where + base = pooledRead r pool + +-- | The time in milliseconds, by which the cache orders the keys by use. +milliseconds :: IO Word64 +milliseconds = round . (* 1000) <$> getPOSIXTime + +-- | Put an extended public key down to be cached, given its balances, if +-- it is worth it: a key with few addresses and few transactions is read +-- from the database as fast as from Redis. The thresholds are those of the +-- configuration, and count as "Haskoin.Store.Cache" counts them. +wantCached :: Member -> XPubSpec -> [XPubBal] -> IO () +wantCached m x bals = + when (m.config.cacheMax > 0 && (length used >= m.config.cacheMinAddrs || txs >= m.config.cacheMinTxs)) $ + atomically . modifyTVar' m.wanted $ \w -> + if HashMap.size w < 1000 then HashMap.insert (xpubId x) x w else w + where + used = filter (not . nullBalance . (.balance)) bals + txs = fromIntegral (sum (map (.balance.txs) used)) :: Int + +-- | Build the entries of the keys that requests asked about and the cache +-- did not have, one at a time, for as long as the store runs. A build that +-- fails is told to a function. The least recently used entries are deleted +-- when there are more than the configuration allows. +-- +-- This is apart from the turns of the member because an entry of a wallet +-- with a long history takes seconds to read from the database, and a +-- member that does not report for that long loses its lease. +memberCacheLoop :: Member -> (String -> IO ()) -> IO a +memberCacheLoop m complain = go + where + go = do + spec <- atomically $ do + w <- readTVar m.wanted + case HashMap.toList w of + [] -> retrySTM + (k, x) : _ -> x <$ writeTVar m.wanted (HashMap.delete k w) + handleAny (complain . show) (build spec) + go + build spec = + readTVarIO m.tip >>= \case + Nothing -> return () + Just block -> do + now <- milliseconds + let tip = encode block + name = decodeUtf8 (xpubId spec) + built <- + handle (\TipMoved -> return (Just Abandoned)) $ + answeringAt m tip (\r pool _ -> cacheBuild m.redis m.keys tip r pool now spec) + took <- subtract now <$> milliseconds + case built of + Just (Built n) | n > 0 -> do + tally m (.builds) 1 + forM_ m.metrics (\x -> addTiming x.buildTime (fromIntegral took)) + m.config.note LevelDebug $ + "Cached xpub " <> name <> ": " <> shown n <> " addresses added in " <> shown took <> " ms" + gone <- cacheEvict m.redis m.keys m.config.cacheMax + when (gone > 0) $ do + tally m (.evictions) gone + m.config.note LevelDebug ("Evicted " <> shown gone <> " xpubs from the cache") + Just Abandoned -> do + tally m (.abandoned) 1 + m.config.note LevelDebug ("Gave up caching xpub " <> name <> ": the fleet or the entry moved on") + _ -> return () + +-- | Bring the cache of extended public keys to the block that this member +-- just moved the fleet tip to, with what the blocks in between did at the +-- addresses that its entries have. The cache is emptied instead when the +-- member cannot say what they did, when the chain was reorganised, which +-- is rare and would need what the abandoned blocks did undone, or when +-- the member has no view of the block. +advanceCache :: Member -> Maybe ByteString -> ByteString -> Maybe Between -> IO () +advanceCache m seen target between = when (m.config.cacheMax > 0) $ do + changes <- case (between, decode target) of + (Just b, Right to) | not b.reorganised -> withViewAt m.views to $ \r -> do + let touched = HashMap.toList (blockChanges r.net r.ctx b.added) + flags <- cacheTracked m.redis m.keys (map fst touched) + forM [x | (x, True) <- zip touched flags] $ \(a, change) -> do + bal <- Q.getBalance r a + return (a, bal, change) + _ -> return Nothing + let why = case (between, changes) of + (Nothing, _) -> "this store cannot say what the blocks since the last tip did" + (Just b, _) | b.reorganised -> "the chain was reorganised" + (_, Nothing) -> "this store has no view of the block" + _ -> "it was at another block than the last tip" + cacheAdvance m.redis m.keys seen target changes >>= \case + CacheEmptied -> wasEmptied m target why + CacheMoved -> + m.config.note LevelDebug $ + "The xpub cache is at block " + <> blockName target + <> ": " + <> shown (maybe 0 length changes) + <> " addresses changed" + _ -> return () + +-- | Count and say that this store emptied the cache, at a block and for a +-- reason. It is information and not a warning: nothing is wrong with what +-- the fleet answers, which comes from the database until entries are +-- built again. Emptied at every block, though, the cache is of no use, +-- and the log is where that shows. +wasEmptied :: Member -> ByteString -> Text -> IO () +wasEmptied m block why = do + tally m (.emptied) 1 + m.config.note LevelInfo ("Emptied the xpub cache at block " <> blockName block <> ": " <> why) + +-- | A block as a log names it. +blockName :: ByteString -> Text +blockName bytes = either (const "?") blockHashToHex (decode bytes :: Either String BlockHash) + +shown :: (Show a) => a -> Text +shown = T.pack . show + +-- | See that the cache of extended public keys does not stay at another +-- block than the fleet tip. It is there for a moment after every move of +-- the tip, until the store that moved it has brought the cache along, and +-- for good if that store stopped before it did. So a member that finds +-- the cache behind the same tip at two turns in a row empties it, and it +-- starts again at the tip. Every turn of a member runs this. +syncCache :: Member -> IO () +syncCache m = when (m.config.cacheMax > 0) $ do + -- how large the cache is, at every turn: it is one small read, and the + -- number is the fleet's, the same from every store + forM_ m.metrics $ \x -> do + (entries, held) <- cacheSize m.redis m.keys + setGauge x.xpubs entries + setGauge x.addresses held + tip <- fmap encode <$> readTVarIO m.tip + at <- cacheTip m.redis m.keys + before <- readTVarIO m.lagging + case tip of + Just t | at /= Just t -> do + when (before == Just t) $ + cacheAdvance m.redis m.keys Nothing t Nothing >>= \case + CacheEmptied -> wasEmptied m t "no store brought it to the fleet tip" + _ -> return () + atomically (writeTVar m.lagging (Just t)) + _ -> atomically (writeTVar m.lagging Nothing) + +-- | The shared pool of a fleet as it is at a tip, for the queries of +-- "Haskoin.Store.Database.Query.Pooled". Every read throws v'TipMoved' if +-- the tip is another one by then, and runs an action if it is not, by which +-- a caller knows that the tip was checked. +redisPool :: R.Connection -> FleetKeys -> ByteString -> IO () -> PoolReads +redisPool conn keys tip checked = + PoolReads + { summaries = \as -> case as of + [] -> return [] + _ -> map summary <$> ask "sums" (map encode as), + addressTxs = \a start n -> do + rows <- ask "txs" (encode a : from start <> [num n]) + return [(number time, h) | [member, time] <- groups 2 rows, Right h <- [decode member]], + addressOuts = \a start n -> do + rows <- ask "outs" (encode a : from start <> [num n]) + let paid time p v s = Unspent {block = MemRef time, outpoint = p, value = v, script = s, address = Just a} + return + [ (paid (number time) p (number v) s, f == "1") + | [member, time, kept, f] <- groups 4 rows, + Right p <- [decode member], + let (v, s) = B.drop 1 <$> C.break (== ' ') kept + ], + spentOutputs = \a ps -> case ps of + [] -> return [] + _ -> map (== '1') . C.unpack . B.concat <$> ask "spent" [encode a, B.concat (map encode ps)], + bodies = \hs -> case hs of + [] -> return [] + _ -> transactions <$> ask "bodies" [B.concat (map encode hs)], + spenders = \ps -> case ps of + [] -> return [] + _ -> do + rows <- ask "spenders" [B.concat (map encode ps)] + return [spender t i | [t, i] <- groups 2 rows], + page = \offset limit -> do + rows <- ask "page" [num offset, num limit] + return [(number time, h) | [member, time] <- groups 2 rows, Right h <- [decode member]], + startingWith = \start -> rights . map decode <$> ask "ids" [B.drop 1 (encode (TxKeyS start))] + } + where + ask what args = poolRead conn keys 32 (Just tip) what args >>= maybe (throwIO TipMoved) (<$ checked) + num :: (Show a) => a -> ByteString + num = C.pack . show + number :: (Num a) => ByteString -> a + number = maybe 0 (fromInteger . fst) . C.readInteger + from :: (Serialize k) => Maybe (UnixTime, k) -> [ByteString] + from = maybe ["", ""] (\(time, k) -> [num time, encode k]) + groups n rows + | null rows = [] + | otherwise = take n rows : groups n (drop n rows) + -- for each transaction: its body, whether it can be replaced by fee, + -- how many of its outputs the pool spends, and those with what spends + -- them + transactions (bytes : flag : count : rest) = + let (spent, more) = splitAt (3 * number count) rest + inputs = + IntMap.fromList + [ (fromIntegral p.index, s) + | [o, t, i] <- groups 3 spent, + Right p <- [outpoint o], + Just s <- [spender t i] + ] + in (body bytes (flag == "1"), inputs) : transactions more + transactions _ = [] + outpoint :: ByteString -> Either String OutPoint + outpoint = decode + summary row = case map number (C.words row) of + [txs, paid, paidCount, spent, spentCount, both, bothCount] -> Just MemSummary {..} + _ -> Nothing + -- whether a transaction can be replaced by fee is what the pool says + -- now, not what the store that offered it found then + body bytes can + | B.null bytes = Nothing + | otherwise = either (const Nothing) (\td -> Just (td :: TxData) {rbf = can}) (decode bytes) + spender t i + | B.null t = Nothing + | otherwise = either (const Nothing) (\h -> Just Spender {txid = h, index = number i}) (decode t) diff --git a/src/Haskoin/Store/Fleet/Pool.hs b/src/Haskoin/Store/Fleet/Pool.hs new file mode 100644 --- /dev/null +++ b/src/Haskoin/Store/Fleet/Pool.hs @@ -0,0 +1,320 @@ +-- | +-- Module : Haskoin.Store.Fleet.Pool +-- Copyright : (c) Haskoin Developers +-- License : MIT +-- Maintainer : jprupp@protonmail.ch +-- Stability : experimental +-- Portability : POSIX +-- +-- The mempool that stores sharing one Redis answer from, as pure decisions: +-- the second part of "A fleet that answers as one" in +-- @docs\/layered-database.md@, after the fleet tip of "Haskoin.Store.Fleet". +-- "Haskoin.Store.Fleet.Redis" carries it out. +-- +-- = The problem +-- +-- Every store has a mempool of its own, filled in the order in which its +-- peers sent it transactions, and no two are the same. Stores that answer +-- from the same block still answer differently if each lays its own mempool +-- on top. +-- +-- = One pool, the mempool as of the fleet tip +-- +-- The stores keep one pool in Redis and all answer from it. It goes with +-- the fleet tip: it holds transactions that are valid on top of the chain +-- up to that block, and it changes with the tip in the same step, so that +-- no request sees a block without what it did to the pool. +-- +-- A store's own mempool does not go away. It is what the store offers to +-- the pool and relays to its peers, and what it answers from when Redis is +-- down. +-- +-- = The rules +-- +-- * __A store offers what it has__ ('offer'). Each input of the transaction +-- must spend an output of a transaction of the pool, or one that the store +-- finds unspent in its view at the fleet tip. A store that is ahead of the +-- tip holds back what only makes sense after its newer blocks. +-- +-- * __The first of two that spend the same output stays__, unless the store +-- that offers the second names the first as replaced, having replaced it +-- by its own rules. This is a rule, not a truth, as it is for a node that +-- keeps the first of two conflicting transactions that it hears of. +-- +-- * __A transaction leaves only for a reason__ ('withdraw', 'advance'): it +-- was replaced, it is too old, or the tip moved to a block that confirms +-- it or spends what it spends. A store that simply does not have a +-- transaction leaves it alone, because another store has it. +-- +-- * __Whatever goes takes along what spends it.__ A transaction whose +-- parent left unconfirmed spends an output that does not exist. +-- +-- * __The pool follows the tip__ ('advance'). The store that moves the tip +-- says what the blocks in between did: which transactions they confirmed +-- and which outputs they spent, and, across a reorganisation, which +-- transactions of the abandoned blocks come back and which are gone for +-- good, as their coinbases are. +-- +-- Transactions and outputs can be of any type that can be compared; the +-- pool only needs to know which transaction made an output. +module Haskoin.Store.Fleet.Pool + ( -- * The pool + Pool (..), + empty, + member, + descendants, + + -- * Offering and withdrawing + Offer (..), + Refusal (..), + offer, + withdraw, + + -- * Following the tip + Change (..), + advance, + + -- * What the pool holds for each address + Entry (..), + AddressPool (..), + Totals (..), + addresses, + totals, + + -- * Replacing by fee + replaceable, + ) +where + +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Maybe (mapMaybe) +import Data.Ord (Down (..)) +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Word (Word64) + +-- | The shared mempool, for transactions of type @t@ and outputs of type +-- @o@. The second and third fields follow from the first, and are kept so +-- that nothing has to be searched for. +data Pool t o = Pool + { -- | the outputs that each transaction spends + spends :: !(Map t [o]), + -- | the transaction that spends each output that is spent + spender :: !(Map o t), + -- | the transactions of the pool that spend outputs of each transaction, + -- whether that one is in the pool or in the chain: a confirmed + -- transaction can come back in a reorganisation, and what spends it must + -- then be found again + children :: !(Map t (Set t)) + } + deriving (Eq, Show) + +-- | A pool with nothing in it. +empty :: Pool t o +empty = Pool {spends = Map.empty, spender = Map.empty, children = Map.empty} + +-- | Whether a transaction is in the pool. +member :: (Ord t) => t -> Pool t o -> Bool +member t pool = Map.member t pool.spends + +-- | The transactions of the pool that spend outputs of the given ones, or +-- of those in turn, with the given ones that are in the pool. +descendants :: (Ord t) => [t] -> Pool t o -> Set t +descendants from pool = go Set.empty (filter (`member` pool) from) + where + go seen [] = seen + go seen (t : rest) + | Set.member t seen = go seen rest + | otherwise = go (Set.insert t seen) (maybe [] Set.toList (Map.lookup t pool.children) <> rest) + +-- | Why a transaction was not taken. +data Refusal t o + = -- | it is in the pool already, which is no harm + Known + | -- | these transactions of the pool spend what it spends, and were there + -- first + Conflict ![t] + | -- | these inputs spend outputs that are neither made by the pool nor + -- unspent at the tip + Orphan ![o] + deriving (Eq, Show) + +-- | What became of an offer. +data Offer t o + = Taken !(Pool t o) + | Refused !(Refusal t o) + deriving (Eq, Show) + +-- | Offer a transaction to the pool, given the transaction that made each +-- output, a test for the outputs that the offering store finds unspent in +-- its view at the fleet tip, the outputs that the transaction spends, and +-- the transactions of the pool that the store replaced with it. +-- +-- Those leave first, with what spends them. The transaction is then taken +-- if nothing left in the pool spends what it spends, and if each of its +-- inputs is made by the pool or unspent at the tip. +offer :: (Ord t, Ord o) => (o -> t) -> (o -> Bool) -> t -> [o] -> [t] -> Pool t o -> Offer t o +offer maker unspent t inputs replaced pool0 + | member t pool0 = Refused Known + | not (null rivals) = Refused (Conflict rivals) + | not (null orphans) = Refused (Orphan orphans) + | otherwise = Taken (insert maker t inputs pool) + where + pool = withdraw replaced pool0 + rivals = Set.toList (Set.fromList (mapMaybe (`Map.lookup` pool.spender) inputs)) + orphans = [o | o <- inputs, not (member (maker o) pool), not (unspent o)] + +-- | Put a transaction in, without asking. +insert :: (Ord t, Ord o) => (o -> t) -> t -> [o] -> Pool t o -> Pool t o +insert maker t inputs pool = + Pool + { spends = Map.insert t inputs pool.spends, + spender = foldl' (\m o -> Map.insert o t m) pool.spender inputs, + children = foldl' (\m o -> Map.insertWith Set.union (maker o) (Set.singleton t) m) pool.children inputs + } + +-- | Take transactions out of the pool, with everything that spends them. +withdraw :: (Ord t, Ord o) => [t] -> Pool t o -> Pool t o +withdraw ts pool = foldl' (flip remove) pool (Set.toList (descendants ts pool)) + +-- | Take one transaction out, leaving what spends it. +remove :: (Ord t, Ord o) => t -> Pool t o -> Pool t o +remove t pool = + Pool + { spends = Map.delete t pool.spends, + spender = foldl' (flip Map.delete) pool.spender inputs, + children = Map.filter (not . Set.null) (Map.map (Set.delete t) pool.children) + } + where + inputs = Map.findWithDefault [] t pool.spends + +-- | What the blocks between two tips did, as far as the pool is concerned. +data Change t o = Change + { -- | transactions of abandoned blocks that can be unconfirmed again, with + -- what they spend, in an order in which each comes after those it spends + returned :: ![(t, [o])], + -- | transactions of abandoned blocks that cannot, such as coinbases: + -- their outputs no longer exist + gone :: ![t], + -- | transactions that the new blocks confirm + confirmed :: ![t], + -- | outputs that the transactions of the new blocks spend + spent :: ![o] + } + deriving (Eq, Show) + +-- | Bring the pool from one tip to another. +-- +-- The abandoned blocks come first: their transactions that can come back +-- do, putting out whatever in the pool spends what they spend, and what +-- spends the others leaves. Then the new blocks: what they +-- confirm leaves the pool, alone, since what spends it now spends an output +-- of the chain; and what spends an output that they spend leaves with +-- everything that spends it. +advance :: (Ord t, Ord o) => (o -> t) -> Change t o -> Pool t o -> Pool t o +advance maker change pool0 = clashed + where + back = foldl' comeBack pool0 change.returned + -- a transaction that was confirmed has the better claim to what it + -- spends: a transaction of the pool that spends the same cannot have + -- been valid, and leaves + comeBack p (t, inputs) + | member t p = p + | otherwise = insert maker t inputs (withdraw (mapMaybe (`Map.lookup` p.spender) inputs) p) + orphaned = concatMap (\t -> maybe [] Set.toList (Map.lookup t back.children)) change.gone + alive = withdraw orphaned back + settled = foldl' (flip remove) alive change.confirmed + clashed = withdraw (mapMaybe (`Map.lookup` settled.spender) change.spent) settled + +-- | What a transaction does at an address, for addresses of type @a@: the +-- entries by address of "Haskoin.Store.Database.Mempool", which a store +-- works out from the transaction alone and gives to the pool with it. +data Entry a o + = -- | it spends from the address or pays to it + Touches !a + | -- | it spends this output of the address, of this amount + Spends !a !o !Word64 + | -- | it pays this output to the address, with this amount + Pays !a !o !Word64 + deriving (Eq, Show) + +-- | What the pool holds for an address: the union of the entries of its +-- transactions at that address, in the order in which queries list them. +data AddressPool t o = AddressPool + { -- | the transactions that touch it with the time each entered a + -- mempool, newest first, and in the order of their ids within a time + txs :: ![(Word64, t)], + -- | the outputs paid to it, in the same order, with their amounts + paid :: ![(Word64, o, Word64)], + -- | the outputs of it that are spent, with their amounts + spent :: !(Map o Word64) + } + deriving (Eq, Show) + +-- | The sums that the pool keeps for an address, so that a balance does +-- not take reading its entries: the summary of +-- 'Haskoin.Store.Database.Types.MemSummary'. +data Totals = Totals + { txs :: !Word64, + paid :: !Word64, + paidCount :: !Word64, + spent :: !Word64, + spentCount :: !Word64, + -- | amount of the outputs that the pool both pays and spends + both :: !Word64, + bothCount :: !Word64 + } + deriving (Eq, Show) + +-- | What a pool holds for each address, given its transactions, each with +-- the time it entered a mempool and its entries. This is the specification +-- of what "Haskoin.Store.Fleet.Redis" keeps up to date as transactions come +-- and go: it depends on which transactions are in the pool and on nothing +-- else, so the tests work it out again after every step and compare. +addresses :: (Ord a, Ord t, Ord o) => [(t, Word64, [Entry a o])] -> Map a (AddressPool t o) +addresses members = Map.map ordered (Map.fromListWith merge (concatMap single members)) + where + single (t, time, entries) = map (one t time) entries + one t time = \case + Touches a -> (a, AddressPool [(time, t)] [] Map.empty) + Spends a o v -> (a, AddressPool [] [] (Map.singleton o v)) + Pays a o v -> (a, AddressPool [] [(time, o, v)] Map.empty) + merge x y = AddressPool (x.txs <> y.txs) (x.paid <> y.paid) (Map.union x.spent y.spent) + ordered p = + AddressPool + (Map.elems (Map.fromList [((Down time, t), (time, t)) | (time, t) <- p.txs])) + (Map.elems (Map.fromList [((Down time, o), (time, o, v)) | (time, o, v) <- p.paid])) + p.spent + +-- | The sums of what a pool holds for an address. +totals :: (Ord o) => AddressPool t o -> Totals +totals p = + Totals + { txs = fromIntegral (length p.txs), + paid = sum [v | (_, _, v) <- p.paid], + paidCount = fromIntegral (length p.paid), + spent = sum (Map.elems p.spent), + spentCount = fromIntegral (Map.size p.spent), + both = sum inside, + bothCount = fromIntegral (length inside) + } + where + inside = [v | (_, o, v) <- p.paid, Map.member o p.spent] + +-- | The transactions of a pool that can be replaced by fee, given those +-- that say so themselves: those, and whatever spends from one that can be. +-- A transaction inherits this from its unconfirmed parents only, so it +-- changes when a parent is confirmed and when one comes back from an +-- abandoned block. This is the specification of what Redis keeps right as +-- transactions come and go. +replaceable :: (Ord t) => (t -> Bool) -> (o -> t) -> Pool t o -> Set t +replaceable signals maker pool = go (Set.filter signals members) + where + members = Map.keysSet pool.spends + inherits found t = any ((`Set.member` found) . maker) (Map.findWithDefault [] t pool.spends) + go found + | grown == found = found + | otherwise = go grown + where + grown = Set.union found (Set.filter (inherits found) members) diff --git a/src/Haskoin/Store/Fleet/Redis.hs b/src/Haskoin/Store/Fleet/Redis.hs new file mode 100644 --- /dev/null +++ b/src/Haskoin/Store/Fleet/Redis.hs @@ -0,0 +1,400 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- Module : Haskoin.Store.Fleet.Redis +-- Copyright : (c) Haskoin Developers +-- License : MIT +-- Maintainer : jprupp@protonmail.ch +-- Stability : experimental +-- Portability : POSIX +-- +-- The rules of "Haskoin.Store.Fleet" carried out against Redis: the state +-- of a fleet in three keys, and a Lua script for each step that has to be +-- one step. +-- +-- = Why scripts +-- +-- Whether a store may report depends on the tip and on the leases of the +-- others, and the block that the tip moves to depends on every report. Read +-- and written in separate commands, each could change in between: two +-- stores would both find themselves alone, or the tip would move to a block +-- that a store had just stopped reporting. Redis runs a script without +-- letting anything else in, so each rule sees one state and changes it at +-- once. +-- +-- = Whose clock +-- +-- Leases are measured on the clock of Redis, read inside the scripts. The +-- stores then need not agree on the time, only on which Redis they share. A +-- time can be given instead, which is how the tests make leases run out +-- without waiting. +-- +-- = Blocks and stores +-- +-- A block is its hash, or any bytes of one fixed size, and a store is a +-- name that no other store of the fleet has. +-- +-- = The shared mempool +-- +-- The rules of "Haskoin.Store.Fleet.Pool" are one more script, with the +-- pool in keys next to those of the tip. A transaction is its id, of one +-- fixed size, and an output is the id of the transaction that made it and +-- four more bytes. An offer says which tip the store checked the +-- transaction against, and is turned away if the tip has moved since: what +-- was unspent at one block may be spent at the next. Moving the tip and +-- changing the pool for the blocks in between is one step ('fleetAdvance'), +-- so that no request finds a block without what it did to the pool. +-- +-- A transaction comes with what it does at each address (t'PoolEntry'), +-- and the script keeps what the pool holds for each address in step: its +-- transactions and the outputs paid to it, each in a sorted set ordered as +-- queries list them, the outputs of it that are spent, and the sums that a +-- balance needs. 'Haskoin.Store.Fleet.Pool.addresses' says what those +-- should be. Kept as the transactions come and go, they cost a few commands +-- for each entry; worked out when asked, a balance would cost a read of +-- every entry of the address, which is what the store's own mempool area +-- did at first and was measured to be thousands of times too slow for a +-- busy address. +module Haskoin.Store.Fleet.Redis + ( FleetKeys (..), + fleetKeys, + Moved (..), + fleetReport, + fleetMove, + fleetTip, + fleetLive, + + -- * The shared mempool + Offered (..), + PoolChange (..), + PoolTx (..), + PoolEntry (..), + poolOffer, + poolWithdraw, + fleetAdvance, + FleetEvent (..), + fleetEventsEnd, + fleetEventsAfter, + poolSpends, + poolBody, + poolRead, + ) +where + +import Data.ByteString (ByteString) +import Data.ByteString qualified as B +import Data.ByteString.Char8 qualified as C +import Data.FileEmbed (embedFile, makeRelativeToProject) +import Data.Word (Word64) +import Database.Redis (Connection, Redis, Reply) +import Database.Redis qualified as R +import Haskoin.Store.Fleet (Time) + +-- | The keys of a fleet in Redis, and the size of its blocks in bytes. +data FleetKeys = FleetKeys + { -- | what every key of the fleet starts with + prefix :: !ByteString, + -- | the fleet tip: a block + tip :: !ByteString, + -- | a hash from each store to the time its lease runs out, in + -- milliseconds + lease :: !ByteString, + -- | a hash from each store to its recent blocks, newest first, one + -- after the other + recent :: !ByteString, + -- | bytes in a block + size :: !Int + } + +-- | The keys of the fleet under a prefix, such as that of the cache of a +-- network, for blocks of a size. +fleetKeys :: ByteString -> Int -> FleetKeys +fleetKeys prefix size = + FleetKeys + { prefix, + tip = prefix <> "fleet:tip", + lease = prefix <> "fleet:lease", + recent = prefix <> "fleet:recent", + size + } + +-- | What became of an attempt to move the tip; see 'Haskoin.Store.Fleet.Move'. +data Moved + = -- | the tip is now this block + MovedTo !ByteString + | -- | the tip is where the live stores agree, or they agree on nothing + Stays + | -- | another store moved the tip first + Raced + deriving (Eq, Show) + +-- | Report the recent blocks of a store, newest first, under a lease of so +-- many milliseconds, given the blocks that the store has views of. Says +-- whether the report was taken: it is not when the store has no view of the +-- tip and another store is live ('Haskoin.Store.Fleet.mayReport'). +fleetReport :: Connection -> FleetKeys -> Maybe Time -> Time -> ByteString -> [ByteString] -> [ByteString] -> IO Bool +fleetReport conn keys clock term store blocks views = + (== 1) <$> run conn (R.eval reportScript (scriptKeys keys) args :: Redis (Either Reply Integer)) + where + args = [store, num term, maybe "" num clock, num keys.size, B.concat blocks, B.concat views] + +-- | Move the tip to the newest block that every live store reported, given +-- the tip that the caller saw. +fleetMove :: Connection -> FleetKeys -> Maybe Time -> Maybe ByteString -> IO Moved +fleetMove conn keys clock seen = + run conn (R.eval moveScript (scriptKeys keys) args) >>= \case + ["moved", block] -> return (MovedTo block) + ["stays"] -> return Stays + ["raced"] -> return Raced + other -> fail ("Unexpected answer of the fleet script: " <> show (other :: [ByteString])) + where + args = [maybe "" id seen, maybe "" num clock, num keys.size] + +-- | The fleet tip, if there is one. +fleetTip :: Connection -> FleetKeys -> IO (Maybe ByteString) +fleetTip conn keys = run conn (R.get keys.tip) + +-- | The stores that have a lease, with the time each runs out, in +-- milliseconds. Leases that ran out are in it until the next report. +fleetLive :: Connection -> FleetKeys -> IO [(ByteString, Time)] +fleetLive conn keys = map (fmap (maybe 0 (fromIntegral . fst) . C.readInteger)) <$> run conn (R.hgetall keys.lease) + +-- | What became of an offer; see 'Haskoin.Store.Fleet.Pool.Offer'. +data Offered + = -- | it is in the pool now + Taken + | -- | it was there already + Known + | -- | these transactions of the pool spend what it spends + Conflict ![ByteString] + | -- | these outputs are neither made by the pool nor unspent at the tip + Orphan ![ByteString] + | -- | the tip is not the one that the store checked the transaction + -- against: check again and offer again + Late + deriving (Eq, Show) + +-- | What a transaction does at an address; see +-- 'Haskoin.Store.Fleet.Pool.Entry'. Addresses, outputs and scripts are +-- whatever bytes the stores of a fleet agree on. +data PoolEntry + = -- | it spends from the address or pays to it + PoolTouches !ByteString + | -- | it spends this output of the address, of this amount + PoolSpends !ByteString !ByteString !Word64 + | -- | it pays this output to the address, with this amount and script + PoolPays !ByteString !ByteString !Word64 !ByteString + deriving (Eq, Show) + +-- | A transaction as the pool keeps it. +data PoolTx = PoolTx + { txid :: !ByteString, + -- | when it entered the mempool of the store that offers it. The pool + -- keeps the time of the first offer, so that every store lists the + -- transaction in the same place. + time :: !Word64, + -- | the outputs that it spends, in the order of its inputs + inputs :: ![ByteString], + -- | what a store needs to answer about it + body :: !ByteString, + -- | whether it says itself that it can be replaced by fee. Whether it + -- can also depends on the transactions of the pool that it spends + -- from, which the pool works out and keeps right as those come and go. + signals :: !Bool, + -- | what it does at each address + entries :: ![PoolEntry] + } + deriving (Eq, Show) + +-- | What the blocks between two tips did; see +-- 'Haskoin.Store.Fleet.Pool.Change'. +data PoolChange = PoolChange + { -- | transactions that come back + returned :: ![PoolTx], + -- | transactions of abandoned blocks that cannot come back + gone :: ![ByteString], + -- | transactions that the new blocks confirm + confirmed :: ![ByteString], + -- | outputs that the new blocks spend + spent :: ![ByteString] + } + deriving (Eq, Show) + +-- | Offer a transaction to the pool: given the size of a transaction id, +-- the tip that the store checked against, the transaction, whether the +-- store finds each output that it spends unspent at that tip, in the order +-- of its inputs, and the transactions that it replaces. +poolOffer :: + Connection -> + FleetKeys -> + Int -> + Maybe ByteString -> + PoolTx -> + [Bool] -> + [ByteString] -> + IO Offered +poolOffer conn keys tsize seen tx unspents replaced = + run conn (R.eval poolScript [] args) >>= \case + ["taken"] -> return Taken + ["known"] -> return Known + "conflict" : rivals -> return (Conflict rivals) + "orphan" : outputs -> return (Orphan outputs) + ["raced"] -> return Late + other -> fail ("Unexpected answer of the pool script: " <> show (other :: [ByteString])) + where + flags = C.pack [if unspent then '1' else '0' | unspent <- unspents] + args = ["offer", keys.prefix, num tsize, maybe "" id seen, flags, B.concat replaced] <> txArgs tx + +-- | Take transactions out of the pool, with all that spends them. Gives +-- those that left. +poolWithdraw :: Connection -> FleetKeys -> Int -> [ByteString] -> IO [ByteString] +poolWithdraw conn keys tsize ts = + run conn (R.eval poolScript [] ["withdraw", keys.prefix, num tsize, B.concat ts]) + +-- | Move the tip to a block and bring the pool there, in one step: given +-- the tip that the caller saw, the block, which must be the one that the +-- live stores agree on, and what the blocks in between did. +-- +-- A store that cannot say what they did, because it does not have the old +-- tip or because the way from it is too long, gives 'Nothing', and the pool +-- is emptied: but only if no other store is live, as when a fleet comes +-- back after all its stores were away. The stores then offer their mempools +-- to the empty pool. With another store live the answer is 'Raced', and +-- the tip waits for a store that knows the way. +-- +-- The last argument is the blocks that the tip moves through, oldest +-- first and the new tip last, for the events of the fleet ('FleetEvent'): +-- with none given, the new tip is the one block told. +fleetAdvance :: + Connection -> + FleetKeys -> + Int -> + Maybe Time -> + Maybe ByteString -> + ByteString -> + Maybe PoolChange -> + [ByteString] -> + IO Moved +fleetAdvance conn keys tsize clock seen target known path = + run conn (R.eval poolScript [] args) >>= \case + ["moved"] -> return (MovedTo target) + ["stays"] -> return Stays + ["raced"] -> return Raced + other -> fail ("Unexpected answer of the pool script: " <> show (other :: [ByteString])) + where + args = + ["advance", keys.prefix, num tsize, maybe "" id seen, target, maybe "" num clock, num keys.size] + <> [maybe "1" (const "0") known] + <> [B.concat change.gone, B.concat change.confirmed, B.concat change.spent] + <> [num (length change.returned)] + <> concatMap txArgs change.returned + <> [B.concat path] + + change = maybe (PoolChange [] [] [] []) id known + +-- | Read from the pool as it is at a tip: given the size of a transaction +-- id, the tip that the caller answers from, what to read and its arguments, +-- as @read.lua@ takes them. 'Nothing' if the tip is another one by now. +poolRead :: Connection -> FleetKeys -> Int -> Maybe ByteString -> ByteString -> [ByteString] -> IO (Maybe [ByteString]) +poolRead conn keys tsize tip what args = + run conn (R.eval readScript [] (what : keys.prefix : num tsize : maybe "" id tip : args)) >>= \case + "ok" : rows -> return (Just rows) + ["raced"] -> return Nothing + other -> fail ("Unexpected answer of the read script: " <> show (take 1 other)) + +-- | Something that happened to the fleet, as every store of it tells its +-- clients. +-- +-- A store alone tells what its own node saw. The stores of a fleet answer +-- from one tip and one pool, and their events have to be those of that tip +-- and that pool: otherwise a client would hear of a transaction from one +-- server and find that the next does not have it. So the script that +-- changes the pool or moves the tip appends what it did to a stream in +-- Redis, in the same step, and every store reads the stream. +data FleetEvent + = -- | the fleet tip moved to this block, or through it + FleetBlock !ByteString + | -- | a transaction entered the pool + FleetEntered !ByteString + | -- | a transaction left the pool unconfirmed + FleetLeft !ByteString + deriving (Eq, Ord, Show) + +-- | The place in the stream of events after the last event that there is: +-- where a store that starts listening now begins. +fleetEventsEnd :: Connection -> FleetKeys -> IO ByteString +fleetEventsEnd conn keys = + run conn (R.sendRequest ["XREVRANGE", keys.prefix <> "fleet:events", "+", "-", "COUNT", "1"]) >>= \case + R.MultiBulk (Just [R.MultiBulk (Just (R.Bulk (Just at) : _))]) -> return at + _ -> return "0-0" + +-- | The events after a place in the stream, each with its place, waiting +-- up to so many milliseconds for one if there is none yet. +fleetEventsAfter :: Connection -> FleetKeys -> ByteString -> Integer -> IO [(ByteString, FleetEvent)] +fleetEventsAfter conn keys from wait = + run conn (R.sendRequest ["XREAD", "BLOCK", num wait, "STREAMS", keys.prefix <> "fleet:events", from]) >>= \case + R.MultiBulk (Just [R.MultiBulk (Just [_, R.MultiBulk (Just records)])]) -> return (concatMap record records) + _ -> return [] + where + record = \case + R.MultiBulk (Just [R.Bulk (Just at), R.MultiBulk (Just fields)]) -> + case (lookup "k" (pairs fields), lookup "h" (pairs fields)) of + (Just "b", Just h) -> [(at, FleetBlock h)] + (Just "t", Just h) -> [(at, FleetEntered h)] + (Just "d", Just h) -> [(at, FleetLeft h)] + _ -> [] + _ -> [] + pairs (R.Bulk (Just k) : R.Bulk (Just v) : more) = (k, v) : pairs more + pairs _ = [] + +-- | A transaction as the arguments of the pool script. +txArgs :: PoolTx -> [ByteString] +txArgs tx = + [tx.txid, num tx.time, B.concat tx.inputs, tx.body, if tx.signals then "1" else "0", num (length tx.entries)] + <> concatMap entry tx.entries + where + entry = \case + PoolTouches a -> ["t", a, "", "", ""] + PoolSpends a o v -> ["s", a, o, num v, ""] + PoolPays a o v s -> ["o", a, o, num v, s] + +-- | The transactions of the pool, each with the outputs that it spends one +-- after the other. +poolSpends :: Connection -> FleetKeys -> IO [(ByteString, ByteString)] +poolSpends conn keys = run conn (R.hgetall (keys.prefix <> "pool:spends")) + +-- | The body of a transaction of the pool. +poolBody :: Connection -> FleetKeys -> ByteString -> IO (Maybe ByteString) +poolBody conn keys t = run conn (R.hget (keys.prefix <> "pool:body") t) + +scriptKeys :: FleetKeys -> [ByteString] +scriptKeys keys = [keys.tip, keys.lease, keys.recent] + +num :: (Show a) => a -> ByteString +num = C.pack . show + +-- | Run Redis commands, throwing if Redis answers with an error. +run :: Connection -> Redis (Either Reply a) -> IO a +run conn f = + R.runRedis conn f >>= \case + Right x -> return x + Left e -> fail ("Redis error: " <> show e) + +-- | 'Haskoin.Store.Fleet.mayReport' and 'Haskoin.Store.Fleet.report' in one +-- step. +reportScript :: ByteString +reportScript = $(makeRelativeToProject "src/Haskoin/Store/Fleet/lua/report.lua" >>= embedFile) + +-- | 'Haskoin.Store.Fleet.move'. +moveScript :: ByteString +moveScript = $(makeRelativeToProject "src/Haskoin/Store/Fleet/lua/move.lua" >>= embedFile) + +-- | What a store reads from the pool, each read with a check that the tip +-- is the one that the store answers from. +readScript :: ByteString +readScript = $(makeRelativeToProject "src/Haskoin/Store/Fleet/lua/read.lua" >>= embedFile) + +-- | 'Haskoin.Store.Fleet.Pool.offer', 'Haskoin.Store.Fleet.Pool.withdraw', +-- and 'Haskoin.Store.Fleet.Pool.advance' with the move of the tip. +poolScript :: ByteString +poolScript = $(makeRelativeToProject "src/Haskoin/Store/Fleet/lua/pool.lua" >>= embedFile) diff --git a/src/Haskoin/Store/Fleet/XPub.hs b/src/Haskoin/Store/Fleet/XPub.hs new file mode 100644 --- /dev/null +++ b/src/Haskoin/Store/Fleet/XPub.hs @@ -0,0 +1,642 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- Module : Haskoin.Store.Fleet.XPub +-- Copyright : (c) Haskoin Developers +-- License : MIT +-- Maintainer : jprupp@protonmail.ch +-- Stability : experimental +-- Portability : POSIX +-- +-- The cache of extended public keys of a fleet of stores: what a store that +-- answers as a member of a fleet ("Haskoin.Store.Fleet.Member") keeps in +-- the Redis that the fleet shares, so that a request about a wallet is one +-- or two reads of Redis instead of a read of the database for each of its +-- addresses. It is built on the shared pool, and described in "The cache +-- of extended public keys of a fleet" in @docs\/layered-database.md@. +-- +-- = What an entry is +-- +-- An entry belongs to one extended public key and has, for the addresses +-- that a scan of the key reads ('Haskoin.Store.Common.scanXPubBals'): +-- +-- * __the chain's layer__: the balance of each address in the chain, the +-- transactions of all of them, and their unspent outputs, as they are at +-- one block, which is the same for every entry and is written next to +-- them; +-- +-- * __the pool's layer__: the transactions of the shared pool that touch +-- those addresses and the outputs that it pays to them. The script of the +-- pool puts them in and takes them out in the step in which it changes +-- the pool, so this layer is the pool, always. +-- +-- Transactions and outputs of both layers are in one list each, ordered as +-- the API orders them, so a page is a range of a sorted set. A balance is +-- the chain's with the summary that the pool keeps for the address. +-- +-- = Why it cannot give another answer than the database +-- +-- A store of a fleet answers from the chain as it was at the fleet tip +-- with the pool on top ("Haskoin.Store.Database.Query.Pooled"). An entry is +-- that same answer worked out beforehand, and it is used only while that +-- holds: +-- +-- * __The chain's layer follows from the chain__ at a block and the +-- addresses. Any store computes the same, so it does not matter which one +-- writes, and there is nothing for stores to disagree on. +-- +-- * __A read answers only where the cache is__, which is a move of the +-- fleet tip and the block that it went to, and only while the tip is +-- there. A block alone would not do: the tip can leave a block and come +-- back to it, as when a block is reverted and mined again, and on the +-- way the pool takes that block's transactions out of the entries and +-- puts them back as unconfirmed. When the tip moves, the store that moved it +-- brings the cache there, with what the blocks in between did to the +-- addresses that entries have ('cacheAdvance'). Until it has, every read +-- is a miss and the store answers from its database. If it never does, or +-- the chain was reorganised, or the pool was emptied, the cache is +-- emptied: the next move finds it at a block that it does not start from. +-- +-- * __The addresses of a key depend on which are used__, and the pool +-- counts. So every read of balances runs the scan again over what the +-- entry has ('window'), and is a miss unless the scan reads exactly the +-- addresses of the entry. The other reads say how many addresses the +-- caller found, and miss if the entry has another number. +-- +-- The alternative that this replaces, "Haskoin.Store.Cache", keeps one +-- store's view of each key and repairs it from that store's events. It is +-- still what a store that is not in a fleet uses. +-- +-- = What it costs +-- +-- An entry is built from the database by the store that missed, in the +-- background, a few addresses at a time ('cacheBuild'); when a key gains +-- addresses only those are read. Each block costs one question to Redis +-- about the addresses that it touches, and a write for those that entries +-- have. +module Haskoin.Store.Fleet.XPub + ( -- * Reading + Cached (..), + Entry (..), + cachedEntry, + cachedTxs, + cachedUnspents, + cachedCount, + window, + + -- * Writing + Built (..), + cacheBuild, + cacheDrop, + cacheHave, + CacheMoved (..), + AddressChange (..), + blockChanges, + cacheTracked, + cacheAdvance, + cacheEvict, + cacheTip, + cacheSize, + + -- * Encoding + xpubId, + score, + position, + nothingPool, + ) +where + +import Control.Monad (forM) +import Data.Bits (shift, (.&.), (.|.)) +import Data.ByteString (ByteString) +import Data.ByteString qualified as B +import Data.ByteString.Char8 qualified as C +import Data.Default (def) +import Data.FileEmbed (embedFile, makeRelativeToProject) +import Data.Functor ((<&>)) +import Data.HashMap.Strict (HashMap) +import Data.HashMap.Strict qualified as HashMap +import Data.Int (Int64) +import Data.IntMap.Strict qualified as IntMap +import Data.List (sortOn) +import Data.Maybe (fromMaybe, mapMaybe) +import Data.Serialize (decode, encode, runPut) +import Data.Serialize.Put (putWord32be, putWord8) +import Data.Text.Encoding (encodeUtf8) +import Data.Word (Word32, Word64) +import Database.Redis (Connection, Redis, Reply) +import Database.Redis qualified as R +import Haskoin + ( Address (..), + Ctx, + Network, + OutPoint (..), + Tx (..), + TxHash, + TxIn (..), + TxOut (..), + addressHash, + encodeHex, + nullOutPoint, + scriptToAddressBS, + sha256, + txHash, + ) +import Haskoin.Store.Common (Limits (..), StoreRead (..), scanXPubBals) +import Haskoin.Store.Data + ( Balance (..), + BlockRef (..), + Prev (..), + TxData (..), + TxRef (..), + Unspent (..), + XPubBal (..), + XPubSpec (..), + XPubUnspent (..), + nullBalance, + zeroBalance, + ) +import Haskoin.Store.Database.Mempool qualified as M +import Haskoin.Store.Database.Query qualified as Q +import Haskoin.Store.Database.Query.Layered (From (..)) +import Haskoin.Store.Database.Query.Pooled (PoolReads (..), pooledRead) +import Haskoin.Store.Database.Reader (DatabaseReader (..)) +import Haskoin.Store.Database.Types (MemSummary (..)) +import Haskoin.Store.Fleet.Redis (FleetKeys (..)) + +------------------------------------------------------------------------------- +-- Encoding +------------------------------------------------------------------------------- + +-- | What an extended public key is called in Redis: the start of a hash of +-- the key and of the kind of its addresses. +xpubId :: XPubSpec -> ByteString +xpubId = encodeUtf8 . encodeHex . B.take 16 . encode . sha256 . encode + +-- | The score of a position in the sorted sets of an entry, such that +-- sorting by score puts the newest first, as the API lists transactions: +-- those of the pool have the negative of the time at which they entered +-- it, and those of the chain a positive number that goes down with height +-- and position in the block. Between equal scores Redis orders members by +-- their bytes, which for hashes and outputs is the order of the database +-- ('Haskoin.Store.Common.txRefKey', 'Haskoin.Store.Common.unspentKey'). +-- +-- It is the score of "Haskoin.Store.Cache", as a whole number: height and +-- position fit in the 53 bits that Redis keeps exactly. +score :: BlockRef -> Int64 +score BlockRef {height = h, position = p} = 0x001fffffffffffff - (h' .|. p') + where + h' = (fromIntegral h .&. 0x07ffffff) `shift` 26 + p' = fromIntegral p .&. 0x03ffffff +score MemRef {timestamp = t} = negate (fromIntegral (t .&. 0x001fffffffffffff)) + +-- | The position that has a score: the inverse of 'score'. +position :: Int64 -> BlockRef +position s + | s < 0 = MemRef {timestamp = fromIntegral (negate s)} + | otherwise = BlockRef {height = fromIntegral (m `shift` (-26)), position = fromIntegral (m .&. 0x03ffffff)} + where + m = 0x001fffffffffffff - s + +-- | A pool that has nothing. The queries of +-- "Haskoin.Store.Database.Query.Pooled" with it answer from the chain +-- alone, which is how the chain's layer of an entry is read. +nothingPool :: PoolReads +nothingPool = + PoolReads + { summaries = return . map (const Nothing), + addressTxs = \_ _ _ -> return [], + addressOuts = \_ _ _ -> return [], + spentOutputs = \_ ps -> return (map (const False) ps), + bodies = return . map (const (Nothing, IntMap.empty)), + spenders = return . map (const Nothing), + page = \_ _ -> return [], + startingWith = \_ -> return [] + } + +------------------------------------------------------------------------------- +-- Reading +------------------------------------------------------------------------------- + +-- | What a read of the cache gave. +data Cached a + = -- | the answer, which is the one that the database gives at the fleet + -- tip with the pool on top + Hit !a + | -- | the cache cannot answer: ask the database + Miss + | -- | the fleet tip is another block than the one that the request + -- answers from: answer again from the new tip + Moved + deriving (Eq, Show, Functor) + +-- | The balances of a cached key, and what the other reads need of them. +data Entry = Entry + { -- | the balances, as 'Haskoin.Store.Common.StoreRead' gives them + balances :: ![XPubBal], + -- | the number of addresses in each of the two chains of the key + sizes :: !(Int, Int), + -- | where each address is in the key. It is worked out when it is + -- asked for, which only a list of unspent outputs does. + paths :: HashMap Address [Word32] + } + deriving (Eq, Show) + +-- | The balances of a key at the fleet tip, with the pool applied, if the +-- cache has the key with exactly the addresses that a scan of it reads +-- now. Arguments: the tip that the request answers from, the initial gap +-- and the gap of the store, and the time in milliseconds, by which the +-- cache knows which keys are in use. +cachedEntry :: Connection -> FleetKeys -> ByteString -> Word32 -> Word32 -> Word64 -> XPubSpec -> IO (Cached Entry) +cachedEntry conn keys tip igap gap now spec = + ask conn keys "bals" [tip, xpubId spec, num now] <&> \case + Hit rows -> maybe Miss Hit (entry (mapMaybe row (groups 3 rows))) + Miss -> Miss + Moved -> Moved + where + row [a, kept, sums] = do + address <- either (const Nothing) Just (decode a) + let (path, bal) = B.splitAt 5 kept + [m, _, _, _, _] <- Just (B.unpack path) + n <- either (const Nothing) Just (decode (B.drop 1 path)) :: Maybe Word32 + let stored = if B.null bal then Nothing else either (const Nothing) Just (decode bal) + chain = fromMaybe (zeroBalance address) stored + return (fromIntegral m, n, maybe chain (M.applySummary chain) (summary sums)) + row _ = Nothing + summary sums = case map number (C.words sums) of + [txs, paid, paidCount, spent, spentCount, both, bothCount] -> Just MemSummary {..} + _ -> Nothing + entry rows = do + balances <- window igap gap rows + let count m = length [() | XPubBal {path = m' : _} <- balances, m' == m] + return + Entry + { balances, + sizes = (count 0, count 1), + paths = HashMap.fromList [(b.balance.address, b.path) | b <- balances] + } + +-- | The balances of a key as a scan of it gives them, from the balances of +-- the addresses that an entry has, each with the chain that it is in and +-- its number there: if the scan, run over them, reads exactly those +-- addresses. 'Nothing' if it would read one that the entry does not have, +-- or would stop before one that it has. +-- +-- This is what makes an entry safe against the gap. The addresses of a key +-- are those up to the last one that is used and so many more, and a +-- payment in the pool counts as use. An entry is built for the addresses +-- of one moment; after a payment to one of its unused addresses the key +-- has more, and after such a payment is dropped it has fewer. Either way +-- this gives 'Nothing', and the store answers from the database and +-- builds the entry again. +window :: Word32 -> Word32 -> [(Word32, Word32, Balance)] -> Maybe [XPubBal] +window igap gap rows + | not (contiguous ext && contiguous chg) = Nothing + | otherwise = do + found <- scanXPubBals (traverse (`HashMap.lookup` known)) igap gap (ext <> [beyond]) (chg <> [beyond]) + if length found == HashMap.size known then Just found else Nothing + where + chain m = sortOn fst [(n, b.address) | (m', n, b) <- rows, m' == m] + ext = chain 0 + chg = chain 1 + contiguous as = map fst as == take (length as) [0 ..] + known = HashMap.fromList [(b.address, b) | (_, _, b) <- rows] + -- an address that the entry does not have, after the last of each + -- chain: a scan that wants more than the entry has asks for it + beyond = (maxBound, other 0) + other :: Word32 -> Address + other i = + let a = PubKeyAddress (addressHash (encode i)) + in if HashMap.member a known then other (i + 1) else a + +-- | A page of the transactions of a cached key, newest first, from where +-- the page starts, given the numbers of addresses that the caller has for +-- the key ('sizes'). +cachedTxs :: Connection -> FleetKeys -> ByteString -> XPubSpec -> (Int, Int) -> From -> Limits -> IO (Cached [TxRef]) +cachedTxs conn keys tip spec (n0, n1) from limits = + ask conn keys "txs" (who <> place from encode <> [num limits.offset, num limits.limit]) <&> fmap refs + where + who = [tip, xpubId spec, num n0, num n1] + refs rows = + [ TxRef {block = position s, txid = h} + | [m, sc] <- groups 2 rows, + Right h <- [decode m], + Just s <- [integer sc] + ] + +-- | A page of the unspent outputs of a cached key, newest first, each with +-- where its address is in the key ('paths'). +cachedUnspents :: + Connection -> + FleetKeys -> + ByteString -> + XPubSpec -> + Entry -> + From -> + Limits -> + IO (Cached [XPubUnspent]) +cachedUnspents conn keys tip spec e from limits = + ask conn keys "outs" (who <> place from first <> [num limits.offset, num limits.limit]) <&> \case + Hit rows -> maybe Miss Hit (mapM output (groups 3 rows)) + Miss -> Miss + Moved -> Moved + where + (n0, n1) = e.sizes + who = [tip, xpubId spec, num n0, num n1] + -- the outputs of the transaction that a page starts at come first + -- among those of its second + first h = encode (OutPoint h 0) + output [o, sc, kept] = do + outpoint <- either (const Nothing) Just (decode o) + s <- integer sc + let (value, more) = C.break (== ' ') kept + (size, rest) = C.break (== ' ') (B.drop 1 more) + (a, script) = B.splitAt (number size) (B.drop 1 rest) + address <- either (const Nothing) Just (decode a) + path <- HashMap.lookup address e.paths + return + XPubUnspent + { path, + unspent = Unspent {block = position s, outpoint, value = number value, script, address = Just address} + } + output _ = Nothing + +-- | The number of transactions of a cached key. +cachedCount :: Connection -> FleetKeys -> ByteString -> XPubSpec -> (Int, Int) -> IO (Cached Word32) +cachedCount conn keys tip spec (n0, n1) = + ask conn keys "count" [tip, xpubId spec, num n0, num n1] <&> \case + Hit [n] -> Hit (number n) + Hit _ -> Miss + Miss -> Miss + Moved -> Moved + +-- | Where a page starts, as the arguments of the script, given the bytes +-- that the members of the score of a transaction are to be no smaller +-- than. +place :: From -> (TxHash -> ByteString) -> [ByteString] +place from bytes = case from of + Top -> ["top", "", ""] + InMempool time h -> ["at", num (score (MemRef time)), bytes h] + InChain ref -> ["score", num (score ref), ""] + +-- | Ask the script something that it answers with rows. +ask :: Connection -> FleetKeys -> ByteString -> [ByteString] -> IO (Cached [ByteString]) +ask conn keys what args = + run conn (R.eval xpubScript [] (what : keys.prefix : "32" : args)) >>= \case + "ok" : rows -> return (Hit rows) + ["miss"] -> return Miss + ["raced"] -> return Moved + other -> fail ("Unexpected answer of the xpub script: " <> show (take 1 other)) + +------------------------------------------------------------------------------- +-- Writing +------------------------------------------------------------------------------- + +-- | What became of an attempt to build an entry. +data Built + = -- | the entry has the addresses of the key now, of which so many were + -- added + Built !Int + | -- | the fleet tip moved, the cache is not at the tip, or another store + -- wrote the entry meanwhile: nothing more was written + Abandoned + deriving (Eq, Show) + +-- | The numbers of addresses that the cache has for a key in each of its +-- two chains, both zero if it does not have the key. +cacheHave :: Connection -> FleetKeys -> XPubSpec -> IO (Int, Int) +cacheHave conn keys spec = + run conn (R.eval xpubScript [] ["have", keys.prefix, "32", xpubId spec]) >>= \case + [n0, n1] -> return (fromInteger n0, fromInteger n1) + other -> fail ("Unexpected answer of the xpub script: " <> show (other :: [Integer])) + +-- | Delete the entry of a key. +cacheDrop :: Connection -> FleetKeys -> XPubSpec -> IO () +cacheDrop conn keys spec = do + _ <- run conn (R.eval xpubScript [] ["drop", keys.prefix, "32", xpubId spec]) :: IO [ByteString] + return () + +-- | Build the entry of a key, or add to it the addresses that the key has +-- gained: given the tip that the fleet is at, the database as it was at +-- that block, the pool, and the time in milliseconds. +-- +-- The addresses of the key are read as a request reads them, from the +-- chain with the pool on top. An entry that has some of them keeps what it +-- has and gets the others; one that has an address that the key no longer +-- has is deleted and built again. The chain's part of each new address is +-- read from the database, and sent a few addresses at a time, so that no +-- one write holds Redis for long: until the last is in, the entry has +-- fewer addresses than the key, and every read of it misses. +-- +-- Each write is taken only while the fleet tip, the block of the cache +-- and the addresses of the entry are what this store found. +cacheBuild :: Connection -> FleetKeys -> ByteString -> DatabaseReader -> PoolReads -> Word64 -> XPubSpec -> IO Built +cacheBuild conn keys tip r pool now spec = do + bals <- (pooledRead r pool).xPubBals spec + let wanted m = [b | b@XPubBal {path = m' : _} <- bals, m' == m] + (w0, w1) = (length (wanted 0), length (wanted 1)) + (h0, h1) <- cacheHave conn keys spec + (n0, n1) <- + if h0 > w0 || h1 > w1 + then cacheDrop conn keys spec >> return (0, 0) + else return (h0, h1) + let new = drop n0 (wanted 0) <> drop n1 (wanted 1) + go (n0, n1) 0 =<< mapM chainOf new + where + chain = pooledRead r nothingPool + chainOf b = do + let a = b.balance.address + bal <- Q.getBalance r a + txs <- chain.getAddressTxs a def + outs <- chain.getAddressUnspents a def + return (b, bal, txs, outs) + weight (_, _, txs, outs) = 1 + length txs + length outs + -- as many addresses as hold about 'chunk' rows between them + batch _ [] = ([], []) + batch room (x : xs) + | room <= 0 = ([], x : xs) + | otherwise = let (now', later) = batch (room - weight x) xs in (x : now', later) + go _ added [] = return (Built added) + go (n0, n1) added todo = do + let (now', later) = batch chunk todo + args = + [tip, xpubId spec, num n0, num n1, num now, num (length now')] + <> concatMap address now' + count m = length [() | (XPubBal {path = m' : _}, _, _, _) <- now', m' == m] + run conn (R.eval xpubScript [] ("build" : keys.prefix : "32" : args)) >>= \case + ["ok"] -> go (n0 + count 0, n1 + count 1) (added + length now') later + [why] | why `elem` ["raced", "behind", "changed"] -> return Abandoned + other -> fail ("Unexpected answer of the xpub script: " <> show (take 1 (other :: [ByteString]))) + address (b, bal, txs, outs) = + [encode b.balance.address, path b.path, maybe "" encode (bal >>= real)] + <> [num (length txs)] + <> concat [[encode t.txid, num (score t.block)] | t <- txs] + <> [num (length outs)] + <> concat [[encode u.outpoint, num (score u.block), num u.value, u.script] | u <- outs] + real b = if nullBalance b then Nothing else Just b + path = \case + [m, n] -> runPut (putWord8 (fromIntegral m) >> putWord32be n) + _ -> "" + +-- | About how many transactions and outputs one write of 'cacheBuild' +-- carries. +chunk :: Int +chunk = 5000 + +-- | What became of an attempt to bring the cache to a block. +data CacheMoved + = -- | the cache is at the block now, with what the blocks did + CacheMoved + | -- | it was there already + CacheStays + | -- | the fleet tip is not that block any more: whoever moves it next + -- sees to the cache + CacheRaced + | -- | the cache was emptied and starts again at the block + CacheEmptied + deriving (Eq, Show) + +-- | What blocks did at an address: the transactions that they added to +-- it, the outputs that they paid to it, and its outputs that they spent. +data AddressChange = AddressChange + { txs :: ![(TxHash, BlockRef)], + paid :: ![(OutPoint, BlockRef, Word64, ByteString)], + spent :: ![OutPoint] + } + deriving (Eq, Show) + +instance Semigroup AddressChange where + a <> b = AddressChange {txs = a.txs <> b.txs, paid = a.paid <> b.paid, spent = a.spent <> b.spent} + +-- | What the transactions of some blocks, in their order, did at each +-- address that they touch. An output that one of them pays and a later one +-- spends is in both lists of its address: 'cacheAdvance' takes out what +-- was spent after it puts in what was paid. +blockChanges :: Network -> Ctx -> [TxData] -> HashMap Address AddressChange +blockChanges net ctx tds = HashMap.fromListWith (flip (<>)) (concatMap one tds) + where + one td = + let h = txHash td.tx + address = either (const Nothing) Just . scriptToAddressBS net ctx + ins = + [ (a, AddressChange {txs = [], paid = [], spent = [i.outpoint]}) + | (n, i) <- zip [0 ..] td.tx.inputs, + i.outpoint /= nullOutPoint, + Just prev <- [IntMap.lookup n td.prevs], + Just a <- [address prev.script] + ] + outs = + [ (a, AddressChange {txs = [], paid = [(OutPoint h n, td.block, o.value, o.script)], spent = []}) + | (n, o) <- zip [0 ..] td.tx.outputs, + Just a <- [address o.script] + ] + touched = HashMap.keys (HashMap.fromList [(a, ()) | (a, _) <- ins <> outs]) + in [(a, AddressChange {txs = [(h, td.block)], paid = [], spent = []}) | a <- touched] <> ins <> outs + +-- | Which of some addresses an entry of the cache has, in their order. +cacheTracked :: Connection -> FleetKeys -> [Address] -> IO [Bool] +cacheTracked conn keys as = concat <$> forM (pieces as) asked + where + asked some = + map (== '1') . C.unpack + <$> run conn (R.eval xpubScript [] ("tracked" : keys.prefix : "32" : map encode some)) + pieces [] = [] + pieces xs = let (now, later) = splitAt 4000 xs in now : pieces later + +-- | Bring the cache from the block that it is taken to be at to the block +-- that the fleet tip has moved to: given what the blocks in between did at +-- the addresses that entries have, each with its balance in the chain at +-- the new block, or 'Nothing' to empty the cache instead, as a store does +-- that cannot say what they did. +-- +-- The cache is also emptied when it is found at another block than the +-- one given: a store moved the tip and did not get to bring the cache +-- along, and what the blocks since did to it is not known here. +cacheAdvance :: + Connection -> + FleetKeys -> + Maybe ByteString -> + ByteString -> + Maybe [(Address, Maybe Balance, AddressChange)] -> + IO CacheMoved +cacheAdvance conn keys from to changes = + run conn (R.eval xpubScript [] ("advance" : keys.prefix : "32" : args)) >>= \case + ["moved"] -> return CacheMoved + ["stays"] -> return CacheStays + ["raced"] -> return CacheRaced + ["emptied"] -> return CacheEmptied + other -> fail ("Unexpected answer of the xpub script: " <> show (take 1 (other :: [ByteString]))) + where + args = + [fromMaybe "" from, to, maybe "1" (const "0") changes, num (maybe 0 length changes)] + <> concatMap one (fromMaybe [] changes) + one (a, bal, c) = + [encode a, maybe "" encode (bal >>= real), num (length c.txs)] + <> concat [[encode h, num (score ref)] | (h, ref) <- c.txs] + <> [num (length c.paid)] + <> concat [[encode p, num (score ref), num v, s] | (p, ref, v, s) <- c.paid] + <> [num (length c.spent)] + <> map encode c.spent + real b = if nullBalance b then Nothing else Just b + +-- | Delete the least recently used entries past so many. Says how many it +-- deleted. +cacheEvict :: Connection -> FleetKeys -> Int -> IO Int +cacheEvict conn keys most = + fromInteger <$> run conn (R.eval xpubScript [] ["evict", keys.prefix, "32", num most]) + +-- | How large the cache is: the number of its entries, one for each +-- extended public key, and the number of addresses that they have between +-- them, which is what its memory in Redis goes with, together with the +-- transactions of those addresses. +cacheSize :: Connection -> FleetKeys -> IO (Int, Int) +cacheSize conn keys = + run conn (R.eval xpubScript [] ["size", keys.prefix, "32"]) >>= \case + [entries, addresses] -> return (fromInteger entries, fromInteger addresses) + other -> fail ("Unexpected answer of the xpub script: " <> show (other :: [Integer])) + +-- | The block that the cache is at, if it is where the fleet tip is: at +-- the same block, by the same move of the tip. +cacheTip :: Connection -> FleetKeys -> IO (Maybe ByteString) +cacheTip conn keys = + run conn (R.eval xpubScript [] ["where", keys.prefix, "32"]) <&> \block -> + if B.null block then Nothing else Just block + +------------------------------------------------------------------------------- +-- Helpers +------------------------------------------------------------------------------- + +num :: (Show a) => a -> ByteString +num = C.pack . show + +number :: (Num a) => ByteString -> a +number = maybe 0 (fromInteger . fst) . C.readInteger + +-- | A score as Redis prints it: a whole number, which every score of an +-- entry is, or, should Redis ever print a large one that way, a number in +-- the notation of floating point numbers. The first is read as a whole +-- number, since reading a floating point number from text takes several +-- microseconds, and a page has a score for each row. +integer :: ByteString -> Maybe Int64 +integer bytes = case C.readInteger bytes of + Just (n, rest) | B.null rest -> Just (fromInteger n) + _ -> case reads (C.unpack bytes) :: [(Double, String)] of + [(d, "")] -> Just (round d) + _ -> Nothing + +groups :: Int -> [a] -> [[a]] +groups n rows + | null rows = [] + | otherwise = take n rows : groups n (drop n rows) + +-- | Run Redis commands, throwing if Redis answers with an error. +run :: Connection -> Redis (Either Reply a) -> IO a +run conn f = + R.runRedis conn f >>= \case + Right x -> return x + Left e -> fail ("Redis error: " <> show e) + +-- | The script of the cache; see its header for what it takes and gives. +xpubScript :: ByteString +xpubScript = $(makeRelativeToProject "src/Haskoin/Store/Fleet/lua/xpub.lua" >>= embedFile) diff --git a/src/Haskoin/Store/Fleet/lua/move.lua b/src/Haskoin/Store/Fleet/lua/move.lua new file mode 100644 --- /dev/null +++ b/src/Haskoin/Store/Fleet/lua/move.lua @@ -0,0 +1,74 @@ +-- Move the tip to the newest block that every live store reported, if the +-- tip is still the one that the caller saw: moveScript in +-- Haskoin.Store.Fleet.Redis, and agreed and move in Haskoin.Store.Fleet. +-- +-- KEYS: the tip, the leases, the recent blocks. +-- ARGV: the tip that the caller saw, or '' for none, the time in +-- milliseconds or '' for the clock of Redis, and the size of a block in +-- bytes. +-- +-- Returns {'moved', block}, {'stays'} or {'raced'}. +local seen, clock, size = ARGV[1], ARGV[2], tonumber(ARGV[3]) + +local tip = redis.call('GET', KEYS[1]) or '' +if tip ~= seen then + return {'raced'} +end + +local now +if clock == '' then + local t = redis.call('TIME') + now = t[1] * 1000 + math.floor(t[2] / 1000) +else + now = tonumber(clock) +end + +-- the stores whose lease has not run out, in the order of their names +local live = {} +local leases = redis.call('HGETALL', KEYS[2]) +for i = 1, #leases, 2 do + if tonumber(leases[i + 1]) > now then + live[#live + 1] = leases[i] + end +end +if #live == 0 then + return {'stays'} +end +table.sort(live) + +local reports = {} +for i, store in ipairs(live) do + reports[i] = redis.call('HGET', KEYS[3], store) or '' +end + +-- the first block of one report that every other report has +local first = reports[1] +for i = 1, #first, size do + local block = string.sub(first, i, i + size - 1) + local everywhere = true + for j = 2, #reports do + local found = false + for k = 1, #reports[j], size do + if string.sub(reports[j], k, k + size - 1) == block then + found = true + break + end + end + if not found then + everywhere = false + break + end + end + if everywhere then + if block == tip then + return {'stays'} + end + redis.call('SET', KEYS[1], block) + -- the moves of the tip are counted, next to it: see pool.lua + redis.call('INCR', string.sub(KEYS[1], 1, -4) .. 'moves') + -- and told to the stores, as pool.lua tells it + redis.call('XADD', string.sub(KEYS[1], 1, -4) .. 'events', 'MAXLEN', '~', '10000', '*', 'k', 'b', 'h', block) + return {'moved', block} + end +end +return {'stays'} diff --git a/src/Haskoin/Store/Fleet/lua/pool.lua b/src/Haskoin/Store/Fleet/lua/pool.lua new file mode 100644 --- /dev/null +++ b/src/Haskoin/Store/Fleet/lua/pool.lua @@ -0,0 +1,477 @@ +-- The shared mempool of a fleet: poolScript in Haskoin.Store.Fleet.Redis, +-- and offer, withdraw and advance in Haskoin.Store.Fleet.Pool. The three are +-- one script because they share how a transaction is put in and taken out. +-- +-- ARGV[1] is what to do, ARGV[2] the prefix of the keys, and ARGV[3] the +-- size of a transaction id in bytes. An output is the id of the transaction +-- that made it and four more bytes. Lists are their items one after the +-- other. +-- +-- A transaction is given as its id, the time it entered a mempool, the +-- outputs that it spends, its body, '1' if it says itself that it can be +-- replaced by fee or '0', the number of its entries by address, and then +-- five arguments for each entry: its kind, the address, an output +-- or '', an amount or '', and a script or ''. The kinds are 't', the +-- transaction touches the address; 's', it spends that output of the +-- address, of that amount; and 'o', it pays that output to the address, +-- with that amount and script. +-- +-- 'offer': the tip that the store saw or '', a string with '1' for each +-- output that the transaction spends and that the store finds unspent at +-- the tip and '0' for the others, the transactions that it replaces, and +-- the transaction. Returns {'taken'}, {'known'}, {'conflict', ...}, +-- {'orphan', ...} or {'raced'}. +-- +-- 'withdraw': the transactions. Returns those that left. +-- +-- 'advance': the tip that the store saw or '', the block to move to, the +-- time in milliseconds or '' for the clock of Redis, the size of a block in +-- bytes, '1' to empty the pool instead of changing it or '0', the +-- transactions that are gone, those that are confirmed, the outputs that +-- are spent, the number of transactions that come back, those +-- transactions, and the blocks that the tip moves through, oldest first, +-- or ''. Returns {'moved'}, {'stays'} or {'raced'}. The pool is +-- emptied for a store that cannot say what the blocks between the two tips +-- did, and only when no other store is live: {'raced'} otherwise. +-- +-- What the pool holds for each address, kept in step with its transactions: +-- its transactions and the outputs paid to it, both ordered newest first, +-- the outputs of it that are spent, and the sums of all that, which are the +-- summary of Haskoin.Store.Database.Types.MemSummary. It also holds every +-- transaction by the time it entered a mempool, which is the list of the +-- mempool, and by its id alone, to find those whose id starts with some +-- bytes. +-- +-- A transaction can be replaced by fee if it says so itself or if it spends +-- from a transaction of the pool that can be. The second changes when a +-- parent is confirmed or comes back from an abandoned block, so the pool +-- keeps the answer apart from the body, and corrects it for what spends a +-- transaction whenever that one comes or goes. An output counts in +-- 'both' while the pool has both the entry that pays it and the entry that +-- spends it, so it is added by the second to come and taken off by the +-- first to go. +-- +-- Every move of the tip is counted, in 'fleet:moves'. The cache of extended +-- public keys answers at one move of the tip and not at one block, since +-- the tip can leave a block and come back to it, and what the pool did to +-- the entries on the way is not undone by coming back. +-- +-- The cache of extended public keys (xpub.lua) has, for each key that it +-- holds, the transactions of its addresses and the outputs paid to them, +-- those of the pool among them. So what the pool puts in or takes out at an +-- address goes in or out of the entry of every key that has the address, +-- here, in the same step. +local what, prefix, tsize = ARGV[1], ARGV[2], tonumber(ARGV[3]) +local osize = tsize + 4 +local key = { + tip = prefix .. 'fleet:tip', + moves = prefix .. 'fleet:moves', + events = prefix .. 'fleet:events', + lease = prefix .. 'fleet:lease', + recent = prefix .. 'fleet:recent', + spends = prefix .. 'pool:spends', + spender = prefix .. 'pool:spender', + body = prefix .. 'pool:body', + kids = prefix .. 'pool:kids:', + entries = prefix .. 'pool:entries', + time = prefix .. 'pool:time', + ids = prefix .. 'pool:ids', + own = prefix .. 'pool:own', + rbf = prefix .. 'pool:rbf', + atx = prefix .. 'pool:atx:', + aout = prefix .. 'pool:aout:', + aval = prefix .. 'pool:aval:', + aspent = prefix .. 'pool:aspent:', + asum = prefix .. 'pool:asum:', + of = prefix .. 'fx:of:', + entry = prefix .. 'fx:e:' +} + +local function split(s, n) + local items = {} + for i = 1, #s, n do + items[#items + 1] = string.sub(s, i, i + n - 1) + end + return items +end + +-- Tell every store of the fleet that something happened: 'b' and a block +-- that the tip moved to or through, 't' and a transaction that entered the +-- pool, 'd' and one that left it unconfirmed. The events go in a stream, in +-- the step that makes the change, so that every store serves the same +-- events in the same order, whatever its own node saw and when. The stream +-- keeps about the last ten thousand. +local function emit(kind, what) + redis.call('XADD', key.events, 'MAXLEN', '~', '10000', '*', 'k', kind, 'h', what) +end + +local function member(t) + return redis.call('HEXISTS', key.spends, t) == 1 +end + +-- the transactions of the pool among these, and all that spend them +local function descendants(from) + local seen, order, todo = {}, {}, {} + for _, t in ipairs(from) do + if member(t) then + todo[#todo + 1] = t + end + end + while #todo > 0 do + local t = table.remove(todo) + if not seen[t] then + seen[t] = true + order[#order + 1] = t + for _, kid in ipairs(redis.call('SMEMBERS', key.kids .. t)) do + todo[#todo + 1] = kid + end + end + end + return order, seen +end + +-- a transaction of the arguments, from a position, and the position after +-- it +local function read(at) + local tx = {id = ARGV[at], time = tonumber(ARGV[at + 1]), inputs = ARGV[at + 2], body = ARGV[at + 3]} + tx.own = ARGV[at + 4] == '1' + local entries = {} + local n = tonumber(ARGV[at + 5]) + at = at + 6 + for i = 1, n do + entries[i] = {ARGV[at], ARGV[at + 1], ARGV[at + 2], ARGV[at + 3], ARGV[at + 4]} + at = at + 5 + end + tx.entries = entries + return tx, at +end + +local function add(a, field, by) + redis.call('HINCRBY', key.asum .. a, field, string.format('%.0f', by)) +end + +-- put the entries of a transaction in, with sign 1, or take them out, with +-- sign -1 +local function account(t, time, entries, sign) + local touched = {} + for _, e in ipairs(entries) do + local kind, a, o, v = e[1], e[2], e[3], tonumber(e[4]) + touched[a] = true + -- the cached keys that have the address + local watching = {} + if kind ~= 's' then + watching = redis.call('SMEMBERS', key.of .. a) + end + if kind == 't' then + if sign > 0 then + redis.call('ZADD', key.atx .. a, -time, t) + else + redis.call('ZREM', key.atx .. a, t) + end + for _, id in ipairs(watching) do + if sign > 0 then + redis.call('ZADD', key.entry .. id .. ':txs', -time, t) + else + redis.call('ZREM', key.entry .. id .. ':txs', t) + end + end + add(a, 'txs', sign) + elseif kind == 's' then + if sign > 0 then + redis.call('HSET', key.aspent .. a, o, e[4]) + else + redis.call('HDEL', key.aspent .. a, o) + end + add(a, 'spent', sign * v) + add(a, 'spentCount', sign) + if redis.call('HEXISTS', key.aval .. a, o) == 1 then + add(a, 'both', sign * v) + add(a, 'bothCount', sign) + end + else + if sign > 0 then + redis.call('ZADD', key.aout .. a, -time, o) + redis.call('HSET', key.aval .. a, o, e[4] .. ' ' .. e[5]) + else + redis.call('ZREM', key.aout .. a, o) + redis.call('HDEL', key.aval .. a, o) + end + for _, id in ipairs(watching) do + if sign > 0 then + redis.call('ZADD', key.entry .. id .. ':outs', -time, o) + redis.call('HSET', key.entry .. id .. ':oval', o, e[4] .. ' ' .. #a .. ' ' .. a .. e[5]) + else + redis.call('ZREM', key.entry .. id .. ':outs', o) + redis.call('HDEL', key.entry .. id .. ':oval', o) + end + end + add(a, 'paid', sign * v) + add(a, 'paidCount', sign) + if redis.call('HEXISTS', key.aspent .. a, o) == 1 then + add(a, 'both', sign * v) + add(a, 'bothCount', sign) + end + end + end + -- an address that no transaction touches has no summary + if sign < 0 then + for a, _ in pairs(touched) do + if tonumber(redis.call('HGET', key.asum .. a, 'txs')) == 0 then + redis.call('DEL', key.asum .. a) + end + end + end +end + +-- work out again whether a transaction of the pool can be replaced by +-- fee, and if that changed, the same for what spends it +local function replaceable(t) + local inputs = redis.call('HGET', key.spends, t) + if not inputs then + return + end + local can = redis.call('SISMEMBER', key.own, t) == 1 + if not can then + for _, o in ipairs(split(inputs, osize)) do + if redis.call('SISMEMBER', key.rbf, string.sub(o, 1, tsize)) == 1 then + can = true + break + end + end + end + if can ~= (redis.call('SISMEMBER', key.rbf, t) == 1) then + if can then + redis.call('SADD', key.rbf, t) + else + redis.call('SREM', key.rbf, t) + end + for _, kid in ipairs(redis.call('SMEMBERS', key.kids .. t)) do + replaceable(kid) + end + end +end + +-- take one transaction out, leaving what spends it: quietly if a block +-- confirmed it, which is no event of the mempool +local function remove(t, quiet) + local inputs = redis.call('HGET', key.spends, t) + if not inputs then + return + end + if not quiet then + emit('d', t) + end + local kept = cmsgpack.unpack(redis.call('HGET', key.entries, t)) + account(t, kept[1], kept[2], -1) + redis.call('HDEL', key.entries, t) + redis.call('ZREM', key.time, t) + redis.call('ZREM', key.ids, t) + for _, o in ipairs(split(inputs, osize)) do + redis.call('HDEL', key.spender, o) + redis.call('SREM', key.kids .. string.sub(o, 1, tsize), t) + end + redis.call('HDEL', key.spends, t) + redis.call('HDEL', key.body, t) + redis.call('SREM', key.own, t) + if redis.call('SREM', key.rbf, t) == 1 then + for _, kid in ipairs(redis.call('SMEMBERS', key.kids .. t)) do + replaceable(kid) + end + end +end + +local function insert(tx) + local t = tx.id + redis.call('HSET', key.spends, t, tx.inputs) + redis.call('HSET', key.body, t, tx.body) + for _, o in ipairs(split(tx.inputs, osize)) do + redis.call('HSET', key.spender, o, t) + redis.call('SADD', key.kids .. string.sub(o, 1, tsize), t) + end + redis.call('HSET', key.entries, t, cmsgpack.pack({tx.time, tx.entries})) + redis.call('ZADD', key.time, tx.time, t) + redis.call('ZADD', key.ids, 0, t) + account(t, tx.time, tx.entries, 1) + if tx.own then + redis.call('SADD', key.own, t) + end + replaceable(t) + emit('t', t) +end + +local function withdraw(from) + local order = descendants(from) + for _, t in ipairs(order) do + remove(t) + end + return order +end + +if what == 'withdraw' then + return withdraw(split(ARGV[4], tsize)) +end + +local tip = redis.call('GET', key.tip) or '' +if tip ~= ARGV[4] then + return {'raced'} +end + +if what == 'offer' then + local flags = ARGV[5] + local tx = read(7) + local t, inputs = tx.id, split(tx.inputs, osize) + if member(t) then + return {'known'} + end + -- what it replaces leaves first, but only if it is taken + local leaving, left = descendants(split(ARGV[6], tsize)) + local rivals, counted = {}, {} + for _, o in ipairs(inputs) do + local s = redis.call('HGET', key.spender, o) + if s and not left[s] and not counted[s] then + counted[s] = true + rivals[#rivals + 1] = s + end + end + if #rivals > 0 then + table.insert(rivals, 1, 'conflict') + return rivals + end + local orphans = {'orphan'} + for i, o in ipairs(inputs) do + local maker = string.sub(o, 1, tsize) + local made = member(maker) and not left[maker] + if not made and string.sub(flags, i, i) ~= '1' then + orphans[#orphans + 1] = o + end + end + if #orphans > 1 then + return orphans + end + for _, gone in ipairs(leaving) do + remove(gone) + end + insert(tx) + return {'taken'} +end + +-- advance: the block must be the one that the live stores agree on +local target, clock, bsize = ARGV[5], ARGV[6], tonumber(ARGV[7]) +if target == tip then + return {'stays'} +end +local now +if clock == '' then + local time = redis.call('TIME') + now = time[1] * 1000 + math.floor(time[2] / 1000) +else + now = tonumber(clock) +end +local live = {} +local leases = redis.call('HGETALL', key.lease) +for i = 1, #leases, 2 do + if tonumber(leases[i + 1]) > now then + live[#live + 1] = leases[i] + end +end +if #live == 0 then + return {'raced'} +end +table.sort(live) +local reports = {} +for i, store in ipairs(live) do + reports[i] = redis.call('HGET', key.recent, store) or '' +end +local agreed = '' +for _, block in ipairs(split(reports[1], bsize)) do + local everywhere = true + for j = 2, #reports do + local found = false + for _, other in ipairs(split(reports[j], bsize)) do + if other == block then + found = true + break + end + end + if not found then + everywhere = false + break + end + end + if everywhere then + agreed = block + break + end +end +if agreed ~= target then + return {'raced'} +end + +-- a store that is alone and does not know the way from the old tip starts +-- the pool again +if ARGV[8] == '1' then + if #live ~= 1 then + return {'raced'} + end + for _, k in ipairs(redis.call('KEYS', prefix .. 'pool:*')) do + redis.call('DEL', k) + end + redis.call('SET', key.tip, target) + redis.call('INCR', key.moves) + emit('b', target) + return {'moved'} +end + +-- the abandoned blocks: what can come back does, and what spends the rest +-- leaves +local at = 13 +for _ = 1, tonumber(ARGV[12]) do + local tx + tx, at = read(at) + if not member(tx.id) then + -- it was confirmed: what spends the same in the pool gives way + local rivals = {} + for _, o in ipairs(split(tx.inputs, osize)) do + local s = redis.call('HGET', key.spender, o) + if s then + rivals[#rivals + 1] = s + end + end + withdraw(rivals) + insert(tx) + end +end +local orphaned = {} +for _, t in ipairs(split(ARGV[9], tsize)) do + for _, kid in ipairs(redis.call('SMEMBERS', key.kids .. t)) do + orphaned[#orphaned + 1] = kid + end +end +withdraw(orphaned) + +-- the new blocks: what they confirm leaves alone, and what spends what they +-- spend leaves with all that spends it +for _, t in ipairs(split(ARGV[10], tsize)) do + remove(t, true) +end +local clashing = {} +for _, o in ipairs(split(ARGV[11], osize)) do + local s = redis.call('HGET', key.spender, o) + if s then + clashing[#clashing + 1] = s + end +end +withdraw(clashing) + +redis.call('SET', key.tip, target) +redis.call('INCR', key.moves) +-- the blocks that the tip moved through, oldest first, if the store that +-- moves it gave them, and the block that it is at now otherwise +local path = split(ARGV[at] or '', bsize) +if #path == 0 then + path = {target} +end +for _, block in ipairs(path) do + emit('b', block) +end +return {'moved'} diff --git a/src/Haskoin/Store/Fleet/lua/read.lua b/src/Haskoin/Store/Fleet/lua/read.lua new file mode 100644 --- /dev/null +++ b/src/Haskoin/Store/Fleet/lua/read.lua @@ -0,0 +1,172 @@ +-- What a store reads from the shared mempool of its fleet: readScript in +-- Haskoin.Store.Fleet.Redis. pool.lua writes what this reads. +-- +-- ARGV[1] is what to read, ARGV[2] the prefix of the keys, ARGV[3] the size +-- of a transaction id in bytes, and ARGV[4] the fleet tip that the store +-- answers from, or ''. Every answer is {'raced'} if the tip is another one: +-- the pool goes with the tip, and laid over the chain of another block it +-- would give a transaction twice or not at all. Otherwise it is {'ok', ...}. +-- +-- 'sums': addresses. For each, its seven sums separated by spaces, in the +-- order of the summary, or '' if the pool has nothing for it. +-- +-- 'txs': an address, the time and id of the transaction to start at or two +-- '', and how many. Transactions of the address from there, newest first: +-- an id and a time for each. +-- +-- 'outs': an address, the time and output to start at or two '', and how +-- many. Outputs paid to the address from there, newest first: for each the +-- output, its time, its amount and script separated by a space, and '1' if +-- the pool spends it or '0'. +-- +-- 'spent': an address and outputs. A string with '1' for each output of the +-- address that the pool spends and '0' for the others. +-- +-- 'bodies': transactions, of the pool or not. For each: its body or '', +-- '1' if it can be replaced by fee or '0', the number of its outputs that +-- the pool spends, and for each of those the output, the transaction that +-- spends it and the number of its input that does. +-- +-- 'spenders': outputs. For each, the transaction that spends it and the +-- number of its input that does, or two ''. +-- +-- 'page': an offset and how many, 0 for all. Transactions of the pool from +-- the newest, an id and a time for each. +-- +-- 'ids': some bytes. The transactions whose id starts with them. +local what, prefix, tsize = ARGV[1], ARGV[2], tonumber(ARGV[3]) +local osize = tsize + 4 +if (redis.call('GET', prefix .. 'fleet:tip') or '') ~= ARGV[4] then + return {'raced'} +end +local answer = {'ok'} + +local function split(s, n) + local items = {} + for i = 1, #s, n do + items[#items + 1] = string.sub(s, i, i + n - 1) + end + return items +end + +-- whether one string of bytes sorts before another, as Redis sorts the +-- members of a sorted set; the comparison of Lua goes by the locale +local function before(a, b) + local n = math.min(#a, #b) + for i = 1, n do + local x, y = string.byte(a, i), string.byte(b, i) + if x ~= y then + return x < y + end + end + return #a < #b +end + +-- the position in a sorted set, ordered newest first, of the member with a +-- time and a name, or where it would be +local function position(zkey, time, member) + if time == '' then + return 0 + end + local score = -tonumber(time) + local at = redis.call('ZCOUNT', zkey, '-inf', '(' .. string.format('%.0f', score)) + for _, m in ipairs(redis.call('ZRANGEBYSCORE', zkey, score, score)) do + if before(m, member) then + at = at + 1 + end + end + return at +end + +if what == 'sums' then + for i = 5, #ARGV do + local s = redis.call('HMGET', prefix .. 'pool:asum:' .. ARGV[i], + 'txs', 'paid', 'paidCount', 'spent', 'spentCount', 'both', 'bothCount') + if s[1] then + for j = 1, 7 do + s[j] = s[j] or '0' + end + answer[#answer + 1] = table.concat(s, ' ') + else + answer[#answer + 1] = '' + end + end +elseif what == 'txs' then + local zkey = prefix .. 'pool:atx:' .. ARGV[5] + local at = position(zkey, ARGV[6], ARGV[7]) + local rows = redis.call('ZRANGE', zkey, at, at + tonumber(ARGV[8]) - 1, 'WITHSCORES') + for i = 1, #rows, 2 do + answer[#answer + 1] = rows[i] + answer[#answer + 1] = string.format('%.0f', -tonumber(rows[i + 1])) + end +elseif what == 'outs' then + local a = ARGV[5] + local zkey = prefix .. 'pool:aout:' .. a + local at = position(zkey, ARGV[6], ARGV[7]) + local rows = redis.call('ZRANGE', zkey, at, at + tonumber(ARGV[8]) - 1, 'WITHSCORES') + for i = 1, #rows, 2 do + answer[#answer + 1] = rows[i] + answer[#answer + 1] = string.format('%.0f', -tonumber(rows[i + 1])) + answer[#answer + 1] = redis.call('HGET', prefix .. 'pool:aval:' .. a, rows[i]) + answer[#answer + 1] = tostring(redis.call('HEXISTS', prefix .. 'pool:aspent:' .. a, rows[i])) + end +elseif what == 'spent' then + local flags = {} + for i, o in ipairs(split(ARGV[6], osize)) do + flags[i] = tostring(redis.call('HEXISTS', prefix .. 'pool:aspent:' .. ARGV[5], o)) + end + answer[2] = table.concat(flags) +elseif what == 'bodies' then + for _, t in ipairs(split(ARGV[5], tsize)) do + answer[#answer + 1] = redis.call('HGET', prefix .. 'pool:body', t) or '' + answer[#answer + 1] = tostring(redis.call('SISMEMBER', prefix .. 'pool:rbf', t)) + -- what spends its outputs: the inputs of the transactions of the pool + -- that spend from it + local spent = {} + for _, kid in ipairs(redis.call('SMEMBERS', prefix .. 'pool:kids:' .. t)) do + for i, input in ipairs(split(redis.call('HGET', prefix .. 'pool:spends', kid), osize)) do + if string.sub(input, 1, tsize) == t then + spent[#spent + 1] = input + spent[#spent + 1] = kid + spent[#spent + 1] = tostring(i - 1) + end + end + end + answer[#answer + 1] = tostring(#spent / 3) + for _, item in ipairs(spent) do + answer[#answer + 1] = item + end + end +elseif what == 'spenders' then + for _, o in ipairs(split(ARGV[5], osize)) do + local s = redis.call('HGET', prefix .. 'pool:spender', o) + local index = '' + if s then + for i, input in ipairs(split(redis.call('HGET', prefix .. 'pool:spends', s), osize)) do + if input == o then + index = tostring(i - 1) + end + end + end + answer[#answer + 1] = s or '' + answer[#answer + 1] = index + end +elseif what == 'page' then + local offset, many = tonumber(ARGV[5]), tonumber(ARGV[6]) + local last = -1 + if many > 0 then + last = offset + many - 1 + end + local rows = redis.call('ZREVRANGE', prefix .. 'pool:time', offset, last, 'WITHSCORES') + for i = 1, #rows, 2 do + answer[#answer + 1] = rows[i] + answer[#answer + 1] = string.format('%.0f', tonumber(rows[i + 1])) + end +elseif what == 'ids' then + local found = redis.call('ZRANGEBYLEX', prefix .. 'pool:ids', + '[' .. ARGV[5], '(' .. ARGV[5] .. string.rep(string.char(255), tsize)) + for _, t in ipairs(found) do + answer[#answer + 1] = t + end +end +return answer diff --git a/src/Haskoin/Store/Fleet/lua/report.lua b/src/Haskoin/Store/Fleet/lua/report.lua new file mode 100644 --- /dev/null +++ b/src/Haskoin/Store/Fleet/lua/report.lua @@ -0,0 +1,54 @@ +-- Note the recent blocks of a store under a lease, if the store may report: +-- reportScript in Haskoin.Store.Fleet.Redis, and mayReport and report in +-- Haskoin.Store.Fleet. +-- +-- KEYS: the tip, the leases, the recent blocks. +-- ARGV: the store, the length of the lease in milliseconds, the time in +-- milliseconds or '' for the clock of Redis, the size of a block in bytes, +-- the recent blocks of the store, newest first, and the blocks that it has +-- views of, each as blocks one after the other. +-- +-- Returns 1 if the report was taken and 0 if the store may not report. +local store, lease, clock, size = ARGV[1], tonumber(ARGV[2]), ARGV[3], tonumber(ARGV[4]) +local recent, views = ARGV[5], ARGV[6] + +local now +if clock == '' then + local t = redis.call('TIME') + now = t[1] * 1000 + math.floor(t[2] / 1000) +else + now = tonumber(clock) +end + +-- whether the store has a view of the tip +local tip = redis.call('GET', KEYS[1]) +local has = not tip +if tip then + for i = 1, #views, size do + if string.sub(views, i, i + size - 1) == tip then + has = true + break + end + end +end + +-- whether another store is live; leases that ran out are forgotten +local alone = true +local leases = redis.call('HGETALL', KEYS[2]) +for i = 1, #leases, 2 do + if tonumber(leases[i + 1]) > now then + if leases[i] ~= store then + alone = false + end + else + redis.call('HDEL', KEYS[2], leases[i]) + redis.call('HDEL', KEYS[3], leases[i]) + end +end + +if not (has or alone) then + return 0 +end +redis.call('HSET', KEYS[2], store, now + lease) +redis.call('HSET', KEYS[3], store, recent) +return 1 diff --git a/src/Haskoin/Store/Fleet/lua/xpub.lua b/src/Haskoin/Store/Fleet/lua/xpub.lua new file mode 100644 --- /dev/null +++ b/src/Haskoin/Store/Fleet/lua/xpub.lua @@ -0,0 +1,401 @@ +-- The cache of extended public keys of a fleet: xpubScript in +-- Haskoin.Store.Fleet.XPub, which says what an entry is and why. pool.lua +-- keeps the part of each entry that comes from the shared mempool. +-- +-- ARGV[1] is what to do, ARGV[2] the prefix of the keys, and ARGV[3] the +-- size of a transaction id in bytes. An output is the id of the transaction +-- that made it and four more bytes. A position in a list is a score, as +-- Haskoin.Store.Fleet.XPub.score gives it: lists are ordered by score and, +-- within one score, by the bytes of the member. What an entry keeps for an +-- output is its amount, a space, the length of its address, a space, the +-- address, and the script. +-- +-- The reads take the fleet tip that the store answers from, the id of a +-- key, and the number of its addresses in each of its two chains as the +-- caller has them. They answer {'raced'} if the fleet tip is another block, +-- {'miss'} if the cache is not where the tip is, if it does not have the key, +-- or if it has it with other addresses, and {'ok', ...} otherwise. +-- +-- 'bals': the tip, the id, and the time in milliseconds, or '' not to note +-- that the key was used. The numbers of addresses are not given, and not +-- checked. For each address of the entry: the address, its path followed +-- by its balance in the chain if it has one, and its seven sums in the +-- pool separated by spaces or ''. A path is five bytes: the chain of the +-- key that the address is in, and its number there. +-- +-- 'txs', 'outs': the tip, the id, the two numbers, where to start, an +-- offset and how many, 0 for all. Where to start is 'top' and two ''; +-- 'score' with a score and ''; or 'at' with a score and the bytes that the +-- members of that score are to be no smaller than. 'txs' gives a +-- transaction and a score for each; 'outs' an output, a score and what is +-- kept for it, leaving out the outputs that the pool spends. +-- +-- 'count': the tip, the id and the two numbers. The number of transactions. +-- +-- 'have': the id. The two numbers of the entry, whatever block the cache is +-- at: {n0, n1}. +-- +-- 'build': the tip, the id, the two numbers that the entry is to have +-- before, the time in milliseconds, the number of addresses to add, and for +-- each: the address, its path, its balance in the chain or '', the number +-- of its transactions in the chain, a transaction and a score for each, the +-- number of its unspent outputs in the chain, and an output, a score, an +-- amount and a script for each. What the pool has for the address is added +-- from the pool. Returns {'ok'}; {'raced'} if the fleet tip is another +-- block; {'behind'} if the cache is at another block; {'changed'} if the +-- entry does not have those two numbers of addresses. +-- +-- 'drop': the id. Deletes the entry. +-- +-- 'tracked': addresses. A string with '1' for each address that an entry +-- has and '0' for the others. +-- +-- 'where': nothing. The block that the cache is at, if it is at the fleet +-- tip as it stands, and '' otherwise. +-- +-- 'advance': the block that the cache is taken to be at or '', the block to +-- bring it to, '1' to empty it or '0', the number of addresses that the +-- blocks in between changed, and for each: the address, its balance in +-- the chain at the new block or '', the number of transactions that the +-- blocks added to it, a transaction and a score for each, the number of +-- outputs that they paid to it, an output, a score, an amount and a script +-- for each, the number of its outputs that they spent, and those outputs. +-- Returns {'moved'}; {'stays'} if the cache is at the new block already; +-- {'raced'} if the fleet tip is not the new block; and {'emptied'} if it +-- had entries and was asked to empty them, or was not where the tip was +-- one move ago, in which case what happened since cannot be told. +-- +-- 'size': nothing. The number of entries, and the number of addresses that +-- they have between them: {entries, addresses}. +-- +-- 'evict': how many entries to keep. Deletes the least recently used ones +-- past that many, and says how many it deleted. +local what, prefix, tsize = ARGV[1], ARGV[2], tonumber(ARGV[3]) +local key = { + fleet = prefix .. 'fleet:tip', + tip = prefix .. 'fx:tip', + lru = prefix .. 'fx:lru', + addrs = prefix .. 'fx:addrs', + of = prefix .. 'fx:of:', + entry = prefix .. 'fx:e:', + spender = prefix .. 'pool:spender', + atx = prefix .. 'pool:atx:', + aout = prefix .. 'pool:aout:', + aval = prefix .. 'pool:aval:', + asum = prefix .. 'pool:asum:' +} + +-- whether one string of bytes sorts before another, as Redis sorts the +-- members of a sorted set; the comparison of Lua goes by the locale +local function before(a, b) + local n = math.min(#a, #b) + for i = 1, n do + local x, y = string.byte(a, i), string.byte(b, i) + if x ~= y then + return x < y + end + end + return #a < #b +end + +local function kept(a, amount, script) + return amount .. ' ' .. #a .. ' ' .. a .. script +end + +local function drop(id) + local e = key.entry .. id .. ':' + local had = redis.call('HKEYS', e .. 'addrs') + for _, a in ipairs(had) do + redis.call('SREM', key.of .. a, id) + end + if #had > 0 then + redis.call('DECRBY', key.addrs, #had) + end + redis.call('DEL', e .. 'addrs', e .. 'meta', e .. 'txs', e .. 'outs', e .. 'oval') + redis.call('ZREM', key.lru, id) +end + +local function empty() + for _, id in ipairs(redis.call('ZRANGE', key.lru, 0, -1)) do + drop(id) + end + -- whatever a script that failed half way left behind + for _, k in ipairs(redis.call('KEYS', prefix .. 'fx:*')) do + redis.call('DEL', k) + end +end + +local function numbers(e) + local n = redis.call('HMGET', e .. 'meta', 'n0', 'n1') + return tonumber(n[1] or '0'), tonumber(n[2] or '0') +end + +if what == 'have' then + local n0, n1 = numbers(key.entry .. ARGV[4] .. ':') + return {n0, n1} +elseif what == 'drop' then + drop(ARGV[4]) + return {'ok'} +elseif what == 'tracked' then + local flags = {} + for i = 4, #ARGV do + flags[#flags + 1] = tostring(redis.call('EXISTS', key.of .. ARGV[i])) + end + return table.concat(flags) +elseif what == 'size' then + return {redis.call('ZCARD', key.lru), tonumber(redis.call('GET', key.addrs) or '0')} +elseif what == 'evict' then + local over = redis.call('ZCARD', key.lru) - tonumber(ARGV[4]) + if over <= 0 then + return 0 + end + for _, id in ipairs(redis.call('ZRANGE', key.lru, 0, over - 1)) do + drop(id) + end + return over +end + +local fleet = redis.call('GET', key.fleet) or '' + +-- Where the cache is, is a move of the fleet tip and the block that it went +-- to. A block alone would not do: the tip can leave a block and come back +-- to it, as when a block is reverted and mined again, and a cache that was +-- not brought along would find itself at the tip, with entries that the +-- pool has taken the transactions of that block out of on the way. +local moves = tonumber(redis.call('GET', prefix .. 'fleet:moves') or '0') +local function place(n, block) + return n .. '@' .. block +end +local here = place(moves, fleet) + +if what == 'where' then + if (redis.call('GET', key.tip) or '') == here then + return fleet + end + return '' +end + +if what == 'advance' then + local from, to = ARGV[4], ARGV[5] + if fleet ~= to then + return {'raced'} + end + local at = redis.call('GET', key.tip) or '' + if at == here then + return {'stays'} + end + -- it can be brought along only from the move before this one + local held = redis.call('ZCARD', key.lru) > 0 + if held and (ARGV[6] == '1' or at ~= place(moves - 1, from)) then + empty() + redis.call('SET', key.tip, here) + return {'emptied'} + end + local changed = tonumber(ARGV[7]) + local i = 8 + for _ = 1, changed do + local a, bal = ARGV[i], ARGV[i + 1] + local ids = redis.call('SMEMBERS', key.of .. a) + local txs, outs, spent = {}, {}, {} + local n = tonumber(ARGV[i + 2]) + i = i + 3 + for _ = 1, n do + txs[#txs + 1] = {ARGV[i], ARGV[i + 1]} + i = i + 2 + end + n = tonumber(ARGV[i]) + i = i + 1 + for _ = 1, n do + outs[#outs + 1] = {ARGV[i], ARGV[i + 1], kept(a, ARGV[i + 2], ARGV[i + 3])} + i = i + 4 + end + n = tonumber(ARGV[i]) + i = i + 1 + for _ = 1, n do + spent[#spent + 1] = ARGV[i] + i = i + 1 + end + for _, id in ipairs(ids) do + local e = key.entry .. id .. ':' + local row = redis.call('HGET', e .. 'addrs', a) + if row then + redis.call('HSET', e .. 'addrs', a, string.sub(row, 1, 5) .. bal) + end + for _, t in ipairs(txs) do + redis.call('ZADD', e .. 'txs', t[2], t[1]) + end + for _, o in ipairs(outs) do + redis.call('ZADD', e .. 'outs', o[2], o[1]) + redis.call('HSET', e .. 'oval', o[1], o[3]) + end + for _, o in ipairs(spent) do + redis.call('ZREM', e .. 'outs', o) + redis.call('HDEL', e .. 'oval', o) + end + end + end + redis.call('SET', key.tip, here) + return {'moved'} +end + +-- everything else is for a store that answers from the fleet tip +local tip, id = ARGV[4], ARGV[5] +local e = key.entry .. id .. ':' +if fleet ~= tip then + return {'raced'} +end + +if what == 'build' then + local at = redis.call('GET', key.tip) + if not at then + -- nothing is cached yet: the cache starts here + redis.call('SET', key.tip, here) + elseif at ~= here then + return {'behind'} + end + local n0, n1 = numbers(e) + if n0 ~= tonumber(ARGV[6]) or n1 ~= tonumber(ARGV[7]) then + return {'changed'} + end + redis.call('ZADD', key.lru, ARGV[8], id) + local i = 10 + for _ = 1, tonumber(ARGV[9]) do + local a, path, bal = ARGV[i], ARGV[i + 1], ARGV[i + 2] + redis.call('HSET', e .. 'addrs', a, path .. bal) + redis.call('SADD', key.of .. a, id) + if string.byte(path, 1) == 0 then + n0 = n0 + 1 + else + n1 = n1 + 1 + end + local n = tonumber(ARGV[i + 3]) + i = i + 4 + for _ = 1, n do + redis.call('ZADD', e .. 'txs', ARGV[i + 1], ARGV[i]) + i = i + 2 + end + n = tonumber(ARGV[i]) + i = i + 1 + for _ = 1, n do + redis.call('ZADD', e .. 'outs', ARGV[i + 1], ARGV[i]) + redis.call('HSET', e .. 'oval', ARGV[i], kept(a, ARGV[i + 2], ARGV[i + 3])) + i = i + 4 + end + -- what the pool has for the address, which pool.lua keeps up from now + local rows = redis.call('ZRANGE', key.atx .. a, 0, -1, 'WITHSCORES') + for j = 1, #rows, 2 do + redis.call('ZADD', e .. 'txs', rows[j + 1], rows[j]) + end + rows = redis.call('ZRANGE', key.aout .. a, 0, -1, 'WITHSCORES') + for j = 1, #rows, 2 do + local o = rows[j] + local value = redis.call('HGET', key.aval .. a, o) + local space = string.find(value, ' ', 1, true) + redis.call('ZADD', e .. 'outs', rows[j + 1], o) + redis.call('HSET', e .. 'oval', o, kept(a, string.sub(value, 1, space - 1), string.sub(value, space + 1))) + end + end + redis.call('HSET', e .. 'meta', 'n0', n0, 'n1', n1) + redis.call('INCRBY', key.addrs, tonumber(ARGV[9])) + return {'ok'} +end + +if (redis.call('GET', key.tip) or '') ~= here then + return {'miss'} +end +local answer = {'ok'} + +if what == 'bals' then + local addrs = redis.call('HGETALL', e .. 'addrs') + if #addrs == 0 then + return {'miss'} + end + if ARGV[6] ~= '' then + redis.call('ZADD', key.lru, ARGV[6], id) + end + -- the pool has a summary for an address when one of its transactions + -- touches it, and those transactions are in the entry, with scores + -- below zero: most keys have none, and are spared a read for each + -- address + local touched = redis.call('ZCOUNT', e .. 'txs', '-inf', '(0') > 0 + for i = 1, #addrs, 2 do + local a = addrs[i] + answer[#answer + 1] = a + answer[#answer + 1] = addrs[i + 1] + local sums = '' + if touched then + local s = redis.call('HMGET', key.asum .. a, + 'txs', 'paid', 'paidCount', 'spent', 'spentCount', 'both', 'bothCount') + if s[1] then + for j = 1, 7 do + s[j] = s[j] or '0' + end + sums = table.concat(s, ' ') + end + end + answer[#answer + 1] = sums + end + return answer +end + +local n0, n1 = numbers(e) +if n0 + n1 == 0 or n0 ~= tonumber(ARGV[6]) or n1 ~= tonumber(ARGV[7]) then + return {'miss'} +end + +if what == 'count' then + return {'ok', tostring(redis.call('ZCARD', e .. 'txs'))} +end + +-- 'txs' and 'outs': the place in the list where the page starts +local zkey = e .. what +local mode, score, bytes = ARGV[8], ARGV[9], ARGV[10] +local offset, many = tonumber(ARGV[11]), tonumber(ARGV[12]) +local first = 0 +if mode ~= 'top' then + first = redis.call('ZCOUNT', zkey, '-inf', '(' .. score) + if mode == 'at' then + for _, m in ipairs(redis.call('ZRANGEBYSCORE', zkey, score, score)) do + if before(m, bytes) then + first = first + 1 + end + end + end +end + +if what == 'txs' then + local last = -1 + if many > 0 then + last = first + offset + many - 1 + end + local rows = redis.call('ZRANGE', zkey, first + offset, last, 'WITHSCORES') + for _, row in ipairs(rows) do + answer[#answer + 1] = row + end + return answer +end + +-- 'outs': those that the pool spends are left out, before the offset +local found, skipped, size = 0, 0, 64 +while many == 0 or found < many do + local rows = redis.call('ZRANGE', zkey, first, first + size - 1, 'WITHSCORES') + if #rows == 0 then + break + end + for j = 1, #rows, 2 do + local o = rows[j] + if redis.call('HEXISTS', key.spender, o) == 0 then + if skipped < offset then + skipped = skipped + 1 + elseif many == 0 or found < many then + found = found + 1 + answer[#answer + 1] = o + answer[#answer + 1] = rows[j + 1] + answer[#answer + 1] = redis.call('HGET', e .. 'oval', o) + end + end + end + first = first + size + size = math.min(4096, size * 4) +end +return answer diff --git a/src/Haskoin/Store/Logic.hs b/src/Haskoin/Store/Logic.hs --- a/src/Haskoin/Store/Logic.hs +++ b/src/Haskoin/Store/Logic.hs @@ -1,13 +1,5 @@ -{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedRecordDot #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE NoFieldSelectors #-} {-# OPTIONS_GHC -Wno-ambiguous-fields #-} -- | @@ -18,12 +10,19 @@ -- Stability : experimental -- Portability : POSIX -- --- Rules to import and revert blocks and transactions. +-- Rules to import and revert blocks and transactions in the layout of +-- version 20 of the database, in which the mempool is written into the +-- indices of the chain. The store no longer imports with them: it runs on +-- the layered layout, with the rules of "Haskoin.Store.Logic.Layered". +-- These are kept as the reference: the tests give the same random histories +-- to both and compare every result and every answer, and that comparison is +-- the evidence that the new layout does what the old one did. -- -- These functions keep every index consistent: transactions, unspent outputs, -- spenders, address transactions, address unspent outputs, balances and the --- mempool. They run in 'ImportM', which buffers all changes and commits them in --- one atomic batch, so a failure leaves the database untouched. +-- mempool. Each takes the 'Writer' of a batch as its first argument and runs +-- in 'IO'; the writer buffers all changes and 'runWriter' commits them in one +-- atomic batch, so a failure leaves the database untouched. -- -- When a block is imported, transactions already in the mempool are confirmed, -- new ones are imported, and mempool transactions that conflict with the block @@ -51,9 +50,13 @@ -- transactions that conflict with it are deleted together with everything that -- spends them. Between mempool transactions, replace-by-fee decides on networks -- that support it; elsewhere the first one seen stays. +-- +-- These rules write unconfirmed transactions into the same indices as the +-- chain. "Haskoin.Store.Logic.Layered" has the rules for a layout that keeps +-- them apart, with the same functions; the store will move to it when that +-- layout replaces this one. module Haskoin.Store.Logic ( ImportException (..), - ImportM, initBest, revertBlock, importBlock, @@ -71,11 +74,11 @@ when, zipWithM_, ) -import qualified Data.ByteString as B +import Data.ByteString qualified as B import Data.Either (rights) -import qualified Data.HashMap.Strict as M -import qualified Data.HashSet as H -import qualified Data.IntMap.Strict as I +import Data.HashMap.Strict qualified as M +import Data.HashSet qualified as H +import Data.IntMap.Strict qualified as I import Data.List (nub) import Data.Maybe ( catMaybes, @@ -113,21 +116,35 @@ txHashToHex, ) import Haskoin.Node (LogLevel (..), logAt) -import Haskoin.Store.Common +import Haskoin.Store.Common (nub', sortTxs) import Haskoin.Store.Data -import Haskoin.Store.Database.Writer (WriterT, writerLogger) +import Haskoin.Store.Database.Writer hiding (deleteSpender, insertSpender) import UnliftIO (Exception, throwIO) --- | Block and transaction import. Failures are thrown as 'ImportException'. --- Writes are buffered and committed together when 'runWriter' finishes, so a --- failed batch commits nothing. -type ImportM = WriterT IO - -- | Log a message with the logger of the writer. -logDebug, logError :: Text -> ImportM () -logDebug msg = writerLogger >>= \l -> logAt LevelDebug l msg -logError msg = writerLogger >>= \l -> logAt LevelError l msg +logDebug, logError :: Writer -> Text -> IO () +logDebug wr = logAt LevelDebug (writerLogger wr) +logError wr = logAt LevelError (writerLogger wr) +-- | Network of the database being written. +getNetwork :: Writer -> IO Network +getNetwork wr = return (writerNet wr) + +-- | Secp256k1 context of the database being written. +getCtx :: Writer -> IO Ctx +getCtx wr = return (writerCtx wr) + +-- | Data of a transaction that is in the database and not deleted. +getActiveTxData :: Writer -> TxHash -> IO (Maybe TxData) +getActiveTxData wr th = + getTxData wr th >>= \case + Just td | not td.deleted -> return (Just td) + _ -> return Nothing + +-- | Balance of an address, or a zero balance if it was never used. +getDefaultBalance :: Writer -> Address -> IO Balance +getDefaultBalance wr a = fromMaybe (zeroBalance a) <$> getBalance wr a + -- | Reasons why an import can fail. data ImportException = -- | the block does not build on the best block @@ -169,14 +186,14 @@ show TxSpent = "Transaction is spent" -- | Import the genesis block if the database has no best block yet. -initBest :: ImportM () -initBest = do - logDebug "Initializing best block" - net <- getNetwork - m <- getBestBlock +initBest :: Writer -> IO () +initBest wr = do + logDebug wr "Initializing best block" + net <- getNetwork wr + m <- getBestBlock wr when (isNothing m) . void $ do - logDebug "Importing Genesis block" - importBlock (genesisBlock net) (genesisNode net) + logDebug wr "Importing Genesis block" + importBlock wr (genesisBlock net) (genesisNode net) -- | Import a transaction into the mempool with the time it arrived. Returns -- 'False' if it is already known. @@ -185,84 +202,84 @@ -- descendants if the network has replace-by-fee; otherwise the transaction is -- rejected with 'DoubleSpend'. Throws an 'ImportException' if the transaction is -- invalid, for example if it spends unknown outputs. -newMempoolTx :: Tx -> UnixTime -> ImportM Bool -newMempoolTx tx w = - getActiveTxData (txHash tx) >>= \case +newMempoolTx :: Writer -> Tx -> UnixTime -> IO Bool +newMempoolTx wr tx w = + getActiveTxData wr (txHash tx) >>= \case Just _ -> return False Nothing -> do -- Check everything before writing, so that a rejected transaction -- leaves the mempool as it was. - replaced <- getConflicts True True tx - checkNewTx (map txHash replaced) tx - mapM_ (deleteSingleTx . txHash) replaced - rbf <- isRBF (MemRef w) tx - _ <- importTx (MemRef w) w rbf tx + replaced <- getConflicts wr True True tx + checkNewTx wr (map txHash replaced) tx + mapM_ (deleteSingleTx wr . txHash) replaced + rbf <- isRBF wr (MemRef w) tx + _ <- importTx wr (MemRef w) w rbf tx return True -- | Data of the best block. Throws 'BestBlockNotFound' if there is none. -bestBlockData :: ImportM BlockData -bestBlockData = do +bestBlockData :: Writer -> IO BlockData +bestBlockData wr = do h <- - getBestBlock >>= \case + getBestBlock wr >>= \case Nothing -> do - logError "Best block unknown" + logError wr "Best block unknown" throwIO BestBlockNotFound Just h -> return h - getBlock h >>= \case + getBlock wr h >>= \case Nothing -> do - logError "Best block not found" + logError wr "Best block not found" throwIO BestBlockNotFound Just b -> return b -- | Revert the best block: make its parent the best block, mark it as not in the -- main chain, move its transactions back to the mempool, and delete its -- coinbase. Throws 'BlockNotBest' if the block is not the best block. -revertBlock :: BlockHash -> ImportM () -revertBlock bh = do +revertBlock :: Writer -> BlockHash -> IO () +revertBlock wr bh = do bd <- - bestBlockData >>= \b -> + bestBlockData wr >>= \b -> if headerHash b.header == bh then return b else do - logError $ + logError wr $ "Cannot revert non-head block: " <> blockHashToHex bh throwIO BlockNotBest - logDebug $ + logDebug wr $ "Obtained block data for " <> blockHashToHex bh - tds <- mapM getImportTxData bd.txs - logDebug $ + tds <- mapM (getImportTxData wr) bd.txs + logDebug wr $ "Obtained import tx data for block " <> blockHashToHex bh - setBest bd.header.prev - logDebug $ + setBest wr bd.header.prev + logDebug wr $ "Set parent as best block " <> blockHashToHex bd.header.prev - insertBlock bd {main = False} - logDebug $ + insertBlock wr bd {main = False} + logDebug wr $ "Updated as not in main chain: " <> blockHashToHex bh - forM_ (drop 1 tds) unConfirmTx - logDebug $ + forM_ (drop 1 tds) (unConfirmTx wr) + logDebug wr $ "Unconfirmed " <> cs (show (length tds)) <> " transactions" - deleteConfirmedTx (txHash (tds !! 0).tx) - logDebug $ + deleteConfirmedTx wr (txHash (tds !! 0).tx) + logDebug wr $ "Deleted coinbase: " <> txHashToHex (txHash (tds !! 0).tx) -- | Check that a block builds on the best block, or that it is the genesis block -- of an empty database. -checkNewBlock :: Block -> BlockNode -> ImportM () -checkNewBlock b n = - getBestBlock >>= \case +checkNewBlock :: Writer -> Block -> BlockNode -> IO () +checkNewBlock wr b n = + getBestBlock wr >>= \case Nothing | isGenesis n -> return () | otherwise -> do - logError $ + logError wr $ "Cannot import non-genesis block: " <> blockHashToHex (headerHash b.header) throwIO BestBlockNotFound Just h | b.header.prev == h -> return () | otherwise -> do - logError $ + logError wr $ "Block does not build on head: " <> blockHashToHex (headerHash b.header) throwIO PrevBlockNotBest @@ -270,57 +287,66 @@ -- | Import the transactions of a block, in dependency order. Mempool transactions -- that conflict with the block are deleted first. Transactions already in the -- mempool are confirmed; others are imported. -importOrConfirm :: BlockNode -> [Tx] -> ImportM [TxData] -importOrConfirm bn txns = do - logDebug "Freeing outputs..." - mapM_ (freeOutputs True False . snd) (reverse txs) - logDebug "Outputs freed" +importOrConfirm :: Writer -> BlockNode -> [Tx] -> IO [TxData] +importOrConfirm wr bn txns = do + logDebug wr "Freeing outputs..." + mapM_ (freeOutputs wr True False . snd) (reverse txs) + logDebug wr "Outputs freed" mapM (uncurry action) txs where txs = sortTxs txns br i = BlockRef {height = bn.height, position = i} bn_time = fromIntegral $ bn.header.timestamp action i tx = - testPresent tx >>= \case + testPresent wr tx >>= \case False -> import_it i tx True -> confirm_it i tx confirm_it i tx = - getActiveTxData (txHash tx) >>= \case + getActiveTxData wr (txHash tx) >>= \case Just t -> do - logDebug $ + logDebug wr $ "Confirming tx: " <> txHashToHex (txHash tx) - confirmTx t (br i) + -- with the time of the block, as the layered rules give it: see + -- 'Haskoin.Store.Logic.Layered.importChainTx'. Version 20 kept + -- the time at which the store first saw the transaction; these + -- rules are what the tests hold the layered ones to, and have + -- to agree with them on it. + td <- confirmTx wr t (br i) + let timed = (td :: TxData) {timestamp = bn_time} + insertTx wr timed + return timed Nothing -> do - logError $ + logError wr $ "Cannot find tx to confirm: " <> txHashToHex (txHash tx) throwIO TxNotFound import_it i tx = do - logDebug $ + logDebug wr $ "Importing tx: " <> txHashToHex (txHash tx) - importTx (br i) bn_time False tx + importTx wr (br i) bn_time False tx -- | Import a block that builds on the best block, and make it the best block. -- Returns its data and the data of its transactions. -importBlock :: Block -> BlockNode -> ImportM (BlockData, [TxData]) -importBlock b n = do - logDebug $ +importBlock :: Writer -> Block -> BlockNode -> IO (BlockData, [TxData]) +importBlock wr b n = do + logDebug wr $ "Checking new block: " <> blockHashToHex (headerHash n.header) - checkNewBlock b n - logDebug "Passed check" - net <- getNetwork + checkNewBlock wr b n + logDebug wr "Passed check" + net <- getNetwork wr let subsidy = computeSubsidy net n.height - bs <- getBlocksAtHeight n.height - logDebug $ + bs <- getBlocksAtHeight wr n.height + logDebug wr $ "Inserting block entries for: " <> blockHashToHex (headerHash n.header) setBlocksAtHeight + wr (nub (headerHash n.header : bs)) n.height - setBest (headerHash n.header) - tds <- importOrConfirm n b.txs + setBest wr (headerHash n.header) + tds <- importOrConfirm wr n b.txs let bd = BlockData { height = n.height, @@ -334,8 +360,8 @@ fee = sum $ map txDataFee tds, outputs = ts_out_val } - insertBlock bd - logDebug $ + insertBlock wr bd + logDebug wr $ "Finished importing block: " <> blockHashToHex (headerHash n.header) return (bd, tds) @@ -351,39 +377,39 @@ -- | Check a transaction that will replace these ones. Outputs that they spend -- count as unspent, and outputs that they create as missing. -checkNewTx :: [TxHash] -> Tx -> ImportM () -checkNewTx replaced tx = do +checkNewTx :: Writer -> [TxHash] -> Tx -> IO () +checkNewTx wr replaced tx = do when (unique_inputs < length tx.inputs) $ do - logError $ + logError wr $ "Transaction spends same output twice: " <> txHashToHex (txHash tx) throwIO DuplicatePrevOutput prevs <- mapM prev_output (prevOuts tx) when (any isNothing prevs) $ do - logError $ + logError wr $ "Orphan: " <> txHashToHex (txHash tx) throwIO Orphan when (isCoinbaseTx tx) $ do - logError $ + logError wr $ "Coinbase cannot be imported into mempool: " <> txHashToHex (txHash tx) throwIO UnexpectedCoinbase when (outputs > sum (map (.value) (catMaybes prevs))) $ do - logError $ + logError wr $ "Insufficient funds for tx: " <> txHashToHex (txHash tx) throwIO InsufficientFunds where prev_output op | op.hash `elem` replaced = return Nothing | otherwise = do - parent <- getActiveTxData op.hash + parent <- getActiveTxData wr op.hash return (parent >>= getTxOut op.index . (.tx)) outputs = sum (map (.value) tx.outputs) unique_inputs = length (nub' (map (.outpoint) tx.inputs)) -- | Unspent outputs spent by a transaction, or 'Nothing' for those that are missing. -getUnspentOutputs :: (StoreReadBase m) => Tx -> m [Maybe Unspent] -getUnspentOutputs tx = mapM getUnspent (prevOuts tx) +getUnspentOutputs :: Writer -> Tx -> IO [Maybe Unspent] +getUnspentOutputs wr tx = mapM (getUnspent wr) (prevOuts tx) -- | Data of a new transaction, from its replace-by-fee flag, position, time and -- the outputs it spends. @@ -404,47 +430,50 @@ -- | Import a transaction at a position in the chain or the mempool. Throws 'Orphan' if it spends a missing output. importTx :: + Writer -> BlockRef -> -- | unix time Word64 -> -- | RBF Bool -> Tx -> - ImportM TxData -importTx br tt rbf tx = do - mus <- getUnspentOutputs tx + IO TxData +importTx wr br tt rbf tx = do + mus <- getUnspentOutputs wr tx us <- forM mus $ \case Nothing -> do - logError $ + logError wr $ "Attempted to import a tx missing UTXO: " <> txHashToHex (txHash tx) throwIO Orphan Just u -> return u let td = prepareTxData rbf br tt tx us - commitAddTx td + commitAddTx wr td return td -- | Move a confirmed transaction back to the mempool. -unConfirmTx :: TxData -> ImportM TxData -unConfirmTx t = confTx t Nothing +unConfirmTx :: Writer -> TxData -> IO TxData +unConfirmTx wr t = confTx wr t Nothing -- | Confirm a mempool transaction at a position in a block. -confirmTx :: TxData -> BlockRef -> ImportM TxData -confirmTx t br = confTx t (Just br) +confirmTx :: Writer -> TxData -> BlockRef -> IO TxData +confirmTx wr t br = confTx wr t (Just br) -- | Move a transaction to a new position in the indices of all its addresses. -replaceAddressTx :: TxData -> BlockRef -> ImportM () -replaceAddressTx t new = do - net <- getNetwork - ctx <- getCtx +replaceAddressTx :: Writer -> TxData -> BlockRef -> IO () +replaceAddressTx wr t new = do + net <- getNetwork wr + ctx <- getCtx wr forM_ (txDataAddresses net ctx t) $ \a -> do deleteAddrTx + wr a TxRef { block = t.block, txid = txHash t.tx } insertAddrTx + wr a TxRef { block = new, @@ -454,14 +483,15 @@ -- | Move an unspent output to a new position in the chain, updating the indices -- and balance of its address. adjustAddressOutput :: + Writer -> OutPoint -> TxOut -> BlockRef -> BlockRef -> - ImportM () -adjustAddressOutput op o old new = do + IO () +adjustAddressOutput wr op o old new = do let pk = o.script - getUnspent op >>= \case + getUnspent wr op >>= \case Nothing -> return () Just u -> do unless (u.block == old) $ @@ -470,11 +500,12 @@ replace_unspent pk where replace_unspent pk = do - net <- getNetwork - ctx <- getCtx + net <- getNetwork wr + ctx <- getCtx wr let ma = eitherToMaybe (scriptToAddressBS net ctx pk) - deleteUnspent op + deleteUnspent wr op insertUnspent + wr Unspent { block = new, outpoint = op, @@ -485,6 +516,7 @@ forM_ ma $ replace_addr_unspent pk replace_addr_unspent pk a = do deleteAddrUnspent + wr a Unspent { block = old, @@ -494,6 +526,7 @@ address = Just a } insertAddrUnspent + wr a Unspent { block = new, @@ -502,22 +535,22 @@ script = pk, address = Just a } - decreaseBalance (confirmed old) a o.value - increaseBalance (confirmed new) a o.value + decreaseBalance wr (confirmed old) a o.value + increaseBalance wr (confirmed new) a o.value -- | Confirm a transaction at a position in a block, or move it back to the mempool -- if no position is given. -confTx :: TxData -> Maybe BlockRef -> ImportM TxData -confTx t mbr = do - replaceAddressTx t new +confTx :: Writer -> TxData -> Maybe BlockRef -> IO TxData +confTx wr t mbr = do + replaceAddressTx wr t new forM_ (zip [0 ..] t.tx.outputs) $ \(n, o) -> do let op = OutPoint (txHash t.tx) n - adjustAddressOutput op o old new - rbf <- isRBF new t.tx + adjustAddressOutput wr op o old new + rbf <- isRBF wr new t.tx let td = (t :: TxData) {block = new, rbf = rbf} - insertTx td - updateMempool td - updateSpendersRBF td + insertTx wr td + updateMempool wr td + updateSpendersRBF wr td return td where new = fromMaybe (MemRef t.timestamp) mbr @@ -525,111 +558,114 @@ -- | Spenders inherit BIP125 signalling from unconfirmed parents only, so their -- flag can change when a parent is confirmed or unconfirmed. -updateSpendersRBF :: TxData -> ImportM () -updateSpendersRBF td = +updateSpendersRBF :: Writer -> TxData -> IO () +updateSpendersRBF wr td = forM_ (nub' (map (.txid) (I.elems td.spenders))) $ \h -> - getActiveTxData h >>= mapM_ update + getActiveTxData wr h >>= mapM_ update where update s = do - rbf <- isRBF s.block s.tx + rbf <- isRBF wr s.block s.tx when (rbf /= s.rbf) $ do let s' = (s :: TxData) {rbf = rbf} - insertTx s' - updateSpendersRBF s' + insertTx wr s' + updateSpendersRBF wr s' -- | Delete the transactions that spend the same outputs as this one, with their -- descendants. The first flag refuses to delete confirmed transactions, and the -- second refuses any deletion on networks without replace-by-fee. -freeOutputs :: Bool -> Bool -> Tx -> ImportM () -freeOutputs memonly rbfcheck tx = - getConflicts memonly rbfcheck tx >>= mapM_ (deleteSingleTx . txHash) +freeOutputs :: Writer -> Bool -> Bool -> Tx -> IO () +freeOutputs wr memonly rbfcheck tx = + getConflicts wr memonly rbfcheck tx >>= mapM_ (deleteSingleTx wr . txHash) -- | Transactions that spend the same outputs as this one, with their -- descendants, in an order in which they can be deleted. getConflicts :: + Writer -> -- | only delete transaction if unconfirmed Bool -> -- | only delete if network has RBF Bool -> Tx -> - ImportM [Tx] -getConflicts memonly rbfcheck tx = do - logDebug $ + IO [Tx] +getConflicts wr memonly rbfcheck tx = do + logDebug wr $ "Getting conflicts for tx " <> txHashToHex (txHash tx) <> "..." let prevs = prevOuts tx - unspents <- mapM getUnspent prevs + unspents <- mapM (getUnspent wr) prevs let spents = [p | (p, Nothing) <- zip prevs unspents] - spndrs <- catMaybes <$> mapM getSpender spents + spndrs <- catMaybes <$> mapM (getSpender wr) spents let txids = H.fromList $ filter (/= txHash tx) $ map (.txid) spndrs - chains <- mapM (getChain memonly rbfcheck) (H.toList txids) + chains <- mapM (getChain wr memonly rbfcheck) (H.toList txids) return . reverse . map snd . sortTxs . M.elems $ M.fromList [(txHash t, t) | t <- concat chains] -- | Delete a transaction and its descendants, confirmed or not. -deleteConfirmedTx :: TxHash -> ImportM () -deleteConfirmedTx = deleteTx False False +deleteConfirmedTx :: Writer -> TxHash -> IO () +deleteConfirmedTx wr = deleteTx wr False False -- | Delete an unconfirmed transaction and its descendants. If the flag is set and -- the network has no replace-by-fee, throw 'DoubleSpend' instead. Does nothing if -- the transaction is not found. -deleteUnconfirmedTx :: Bool -> TxHash -> ImportM () -deleteUnconfirmedTx rbfcheck th = - getActiveTxData th >>= \case - Just _ -> deleteTx True rbfcheck th +deleteUnconfirmedTx :: Writer -> Bool -> TxHash -> IO () +deleteUnconfirmedTx wr rbfcheck th = + getActiveTxData wr th >>= \case + Just _ -> deleteTx wr True rbfcheck th Nothing -> - logDebug $ + logDebug wr $ "Not found or already deleted: " <> txHashToHex th -- | Delete a transaction and its descendants. deleteTx :: + Writer -> -- | only delete transaction if unconfirmed Bool -> -- | only delete if network has RBF Bool -> TxHash -> - ImportM () -deleteTx memonly rbfcheck th = do - chain <- getChain memonly rbfcheck th - logDebug $ + IO () +deleteTx wr memonly rbfcheck th = do + chain <- getChain wr memonly rbfcheck th + logDebug wr $ "Deleting " <> cs (show (length chain)) <> " txs from chain leading to " <> txHashToHex th - mapM_ (\t -> let h = txHash t in deleteSingleTx h >> return h) chain + mapM_ (\t -> let h = txHash t in deleteSingleTx wr h >> return h) chain -- | A transaction and all its descendants, in an order in which they can be -- deleted: spenders first. getChain :: + Writer -> -- | only delete transaction if unconfirmed Bool -> -- | only delete if network has RBF Bool -> TxHash -> - ImportM [Tx] -getChain memonly rbfcheck th' = do - logDebug $ + IO [Tx] +getChain wr memonly rbfcheck th' = do + logDebug wr $ "Getting chain for tx " <> txHashToHex th' sort_clean <$> go M.empty (H.singleton th') where sort_clean = reverse . map snd . sortTxs get_tx th = - getActiveTxData th >>= \case + getActiveTxData wr th >>= \case Nothing -> do - logDebug $ + logDebug wr $ "Transaction not found: " <> txHashToHex th return Nothing Just td | memonly && confirmed td.block -> do - logError $ + logError wr $ "Transaction already confirmed: " <> txHashToHex th throwIO TxConfirmed | rbfcheck -> - getNetwork >>= \net -> + getNetwork wr >>= \net -> if net.replaceByFee then return $ Just td else do - logError $ + logError wr $ "Double-spending transaction: " <> txHashToHex th throwIO DoubleSpend @@ -643,7 +679,7 @@ txm' = txmn <> txm if H.null pdg' then do - logDebug $ + logDebug wr $ "Chain for tx " <> txHashToHex th' <> " contains " @@ -653,43 +689,43 @@ else go txm' pdg' -- | Delete a transaction that nothing spends. Throws 'TxSpent' otherwise. -deleteSingleTx :: TxHash -> ImportM () -deleteSingleTx th = - getActiveTxData th >>= \case +deleteSingleTx :: Writer -> TxHash -> IO () +deleteSingleTx wr th = + getActiveTxData wr th >>= \case Nothing -> do - logError $ + logError wr $ "Already deleted: " <> txHashToHex th throwIO TxNotFound Just td -> if I.null td.spenders then do - logDebug $ + logDebug wr $ "Deleting tx: " <> txHashToHex th - commitDelTx td + commitDelTx wr td else do - logError $ + logError wr $ "Tried to delete spent tx: " <> txHashToHex th throwIO TxSpent -- | Remove a transaction from every index and mark it as deleted. -commitDelTx :: TxData -> ImportM () -commitDelTx = commitModTx False +commitDelTx :: Writer -> TxData -> IO () +commitDelTx wr = commitModTx wr False -- | Add a transaction to every index. -commitAddTx :: TxData -> ImportM () -commitAddTx = commitModTx True +commitAddTx :: Writer -> TxData -> IO () +commitAddTx wr = commitModTx wr True -- | Add a transaction to every index, or remove it if the flag is 'False'. -commitModTx :: Bool -> TxData -> ImportM () -commitModTx add tx_data = do - net <- getNetwork - ctx <- getCtx +commitModTx :: Writer -> Bool -> TxData -> IO () +commitModTx wr add tx_data = do + net <- getNetwork wr + ctx <- getCtx wr mapM_ mod_addr_tx (txDataAddresses net ctx td) mod_outputs mod_unspent - insertTx td - updateMempool td + insertTx wr td + updateMempool wr td where tx = td.tx br = td.block @@ -697,50 +733,50 @@ tx_ref = TxRef br (txHash tx) mod_addr_tx a | add = do - insertAddrTx a tx_ref - modAddressCount add a + insertAddrTx wr a tx_ref + modAddressCount wr add a | otherwise = do - deleteAddrTx a tx_ref - modAddressCount add a + deleteAddrTx wr a tx_ref + modAddressCount wr add a mod_unspent - | add = spendOutputs tx - | otherwise = unspendOutputs tx + | add = spendOutputs wr tx + | otherwise = unspendOutputs wr tx mod_outputs - | add = addOutputs br tx - | otherwise = delOutputs br tx + | add = addOutputs wr br tx + | otherwise = delOutputs wr br tx -- | Add a transaction to the mempool if it is unconfirmed, or remove it otherwise. -updateMempool :: TxData -> ImportM () -updateMempool td@TxData {deleted = True} = - deleteFromMempool (txHash td.tx) -updateMempool td@TxData {block = MemRef t} = - addToMempool (txHash td.tx) t -updateMempool td@TxData {block = BlockRef {}} = - deleteFromMempool (txHash td.tx) +updateMempool :: Writer -> TxData -> IO () +updateMempool wr td@TxData {deleted = True} = + deleteFromMempool wr (txHash td.tx) +updateMempool wr td@TxData {block = MemRef t} = + addToMempool wr (txHash td.tx) t +updateMempool wr td@TxData {block = BlockRef {}} = + deleteFromMempool wr (txHash td.tx) -- | Mark the outputs spent by a transaction as spent. -spendOutputs :: Tx -> ImportM () -spendOutputs tx = - zipWithM_ (spendOutput (txHash tx)) [0 ..] (prevOuts tx) +spendOutputs :: Writer -> Tx -> IO () +spendOutputs wr tx = + zipWithM_ (spendOutput wr (txHash tx)) [0 ..] (prevOuts tx) -- | Add the outputs of a transaction as unspent. -addOutputs :: BlockRef -> Tx -> ImportM () -addOutputs br tx = - zipWithM_ (addOutput br . OutPoint (txHash tx)) [0 ..] tx.outputs +addOutputs :: Writer -> BlockRef -> Tx -> IO () +addOutputs wr br tx = + zipWithM_ (addOutput wr br . OutPoint (txHash tx)) [0 ..] tx.outputs -- | Whether an unconfirmed transaction can be replaced by fee: it signals BIP125 -- in one of its inputs, or it spends an unconfirmed transaction that can be -- replaced. Always 'False' for confirmed transactions and on networks without -- replace-by-fee. isRBF :: - (StoreReadBase m) => + Writer -> BlockRef -> Tx -> - m Bool -isRBF br tx + IO Bool +isRBF wr br tx | confirmed br = return False | otherwise = - getNetwork >>= \net -> + getNetwork wr >>= \net -> if net.replaceByFee then go else return False @@ -752,7 +788,7 @@ let hs = nub' $ map (.outpoint.hash) tx.inputs ck [] = return False ck (h : hs') = - getActiveTxData h >>= \case + getActiveTxData wr h >>= \case Nothing -> return False Just t | confirmed t.block -> ck hs' @@ -761,29 +797,30 @@ in ck hs -- | Add an unspent output. -addOutput :: BlockRef -> OutPoint -> TxOut -> ImportM () -addOutput = modOutput True +addOutput :: Writer -> BlockRef -> OutPoint -> TxOut -> IO () +addOutput wr = modOutput wr True -- | Delete an output. -delOutput :: BlockRef -> OutPoint -> TxOut -> ImportM () -delOutput = modOutput False +delOutput :: Writer -> BlockRef -> OutPoint -> TxOut -> IO () +delOutput wr = modOutput wr False -- | Add an unspent output, or delete it if the flag is 'False', updating the indices and balance of its address. modOutput :: + Writer -> Bool -> BlockRef -> OutPoint -> TxOut -> - ImportM () -modOutput add br op o = do - net <- getNetwork - ctx <- getCtx + IO () +modOutput wr add br op o = do + net <- getNetwork wr + ctx <- getCtx wr let ma = eitherToMaybe (scriptToAddressBS net ctx o.script) mod_unspent ma forM_ ma $ \a -> do mod_addr_unspent a (u ma) - modBalance (confirmed br) add a o.value - modifyReceived a v + modBalance wr (confirmed br) add a o.value + modifyReceived wr a v where v | add = (+ o.value) @@ -797,25 +834,25 @@ address = ma } mod_unspent ma - | add = insertUnspent (u ma) - | otherwise = deleteUnspent op + | add = insertUnspent wr (u ma) + | otherwise = deleteUnspent wr op mod_addr_unspent - | add = insertAddrUnspent - | otherwise = deleteAddrUnspent + | add = insertAddrUnspent wr + | otherwise = deleteAddrUnspent wr -- | Delete the outputs of a transaction. -delOutputs :: BlockRef -> Tx -> ImportM () -delOutputs br tx = +delOutputs :: Writer -> BlockRef -> Tx -> IO () +delOutputs wr br tx = forM_ (zip [0 ..] tx.outputs) $ \(i, o) -> do let op = OutPoint (txHash tx) i - delOutput br op o + delOutput wr br op o -- | Data of a transaction. Throws 'TxNotFound' if it is missing or deleted. -getImportTxData :: TxHash -> ImportM TxData -getImportTxData th = - getActiveTxData th >>= \case +getImportTxData :: Writer -> TxHash -> IO TxData +getImportTxData wr th = + getActiveTxData wr th >>= \case Nothing -> do - logDebug $ "Tx not found: " <> txHashToHex th + logDebug wr $ "Tx not found: " <> txHashToHex th throwIO TxNotFound Just d -> return d @@ -826,50 +863,50 @@ return $ tx.outputs !! fromIntegral i -- | Record which input spends an output. -insertSpender :: OutPoint -> Spender -> ImportM () -insertSpender op s = do - td <- getImportTxData op.hash +insertSpender :: Writer -> OutPoint -> Spender -> IO () +insertSpender wr op s = do + td <- getImportTxData wr op.hash let p = td.spenders p' = I.insert (fromIntegral op.index) s p td' = (td :: TxData) {spenders = p'} - insertTx td' + insertTx wr td' -- | Forget which input spends an output. -deleteSpender :: OutPoint -> ImportM () -deleteSpender op = do - td <- getImportTxData op.hash +deleteSpender :: Writer -> OutPoint -> IO () +deleteSpender wr op = do + td <- getImportTxData wr op.hash let p = td.spenders p' = I.delete (fromIntegral op.index) p td' = (td :: TxData) {spenders = p'} - insertTx td' + insertTx wr td' -- | Spend an unspent output with an input of a transaction. -spendOutput :: TxHash -> Word32 -> OutPoint -> ImportM () -spendOutput th ix op = do +spendOutput :: Writer -> TxHash -> Word32 -> OutPoint -> IO () +spendOutput wr th ix op = do u <- - getUnspent op >>= \case + getUnspent wr op >>= \case Just u -> return u Nothing -> error $ "Could not find UTXO to spend: " <> show op - deleteUnspent op - insertSpender op (Spender th ix) + deleteUnspent wr op + insertSpender wr op (Spender th ix) let pk = u.script - net <- getNetwork - ctx <- getCtx + net <- getNetwork wr + ctx <- getCtx wr forM_ (scriptToAddressBS net ctx pk) $ \a -> do - decreaseBalance (confirmed u.block) a u.value - deleteAddrUnspent a u + decreaseBalance wr (confirmed u.block) a u.value + deleteAddrUnspent wr a u -- | Make the outputs spent by a transaction unspent again. -unspendOutputs :: Tx -> ImportM () -unspendOutputs = mapM_ unspendOutput . prevOuts +unspendOutputs :: Writer -> Tx -> IO () +unspendOutputs wr = mapM_ (unspendOutput wr) . prevOuts -- | Make an output unspent again. -unspendOutput :: OutPoint -> ImportM () -unspendOutput op = do - net <- getNetwork - ctx <- getCtx +unspendOutput :: Writer -> OutPoint -> IO () +unspendOutput wr op = do + net <- getNetwork wr + ctx <- getCtx wr t <- - getActiveTxData op.hash >>= \case + getActiveTxData wr op.hash >>= \case Nothing -> error $ "Could not find tx data: " <> show op.hash Just t -> return t let o = @@ -885,38 +922,39 @@ outpoint = op, address = m } - deleteSpender op - insertUnspent u + deleteSpender wr op + insertUnspent wr u forM_ m $ \a -> do - insertAddrUnspent a u - increaseBalance (confirmed u.block) a o.value + insertAddrUnspent wr a u + increaseBalance wr (confirmed u.block) a o.value -- | Change the total received by an address. -modifyReceived :: Address -> (Word64 -> Word64) -> ImportM () -modifyReceived a f = do - b <- getDefaultBalance a - setBalance b {received = f b.received} +modifyReceived :: Writer -> Address -> (Word64 -> Word64) -> IO () +modifyReceived wr a f = do + b <- getDefaultBalance wr a + setBalance wr b {received = f b.received} -- | Remove an output from the confirmed or unconfirmed balance of an address. -decreaseBalance :: Bool -> Address -> Word64 -> ImportM () -decreaseBalance conf = modBalance conf False +decreaseBalance :: Writer -> Bool -> Address -> Word64 -> IO () +decreaseBalance wr conf = modBalance wr conf False -- | Add an output to the confirmed or unconfirmed balance of an address. -increaseBalance :: Bool -> Address -> Word64 -> ImportM () -increaseBalance conf = modBalance conf True +increaseBalance :: Writer -> Bool -> Address -> Word64 -> IO () +increaseBalance wr conf = modBalance wr conf True -- | Add or remove an output from the confirmed or unconfirmed balance of an address, and its count of unspent outputs. modBalance :: + Writer -> -- | confirmed Bool -> -- | add Bool -> Address -> Word64 -> - ImportM () -modBalance conf add a val = do - b <- getDefaultBalance a - setBalance $ (g . f) b + IO () +modBalance wr conf add a val = do + b <- getDefaultBalance wr a + setBalance wr $ (g . f) b where g b = (b :: Balance) {utxo = m 1 b.utxo} f b @@ -927,10 +965,10 @@ | otherwise = subtract -- | Increase or decrease the number of transactions of an address. -modAddressCount :: Bool -> Address -> ImportM () -modAddressCount add a = do - b <- getDefaultBalance a - setBalance b {txs = f b.txs} +modAddressCount :: Writer -> Bool -> Address -> IO () +modAddressCount wr add a = do + b <- getDefaultBalance wr a + setBalance wr b {txs = f b.txs} where f | add = (+ 1) @@ -960,5 +998,5 @@ prevOuts tx = filter (/= nullOutPoint) (map (.outpoint) tx.inputs) -- | Whether a transaction is in the database and not deleted. -testPresent :: (StoreReadBase m) => Tx -> m Bool -testPresent tx = isJust <$> getActiveTxData (txHash tx) +testPresent :: Writer -> Tx -> IO Bool +testPresent wr tx = isJust <$> getActiveTxData wr (txHash tx) diff --git a/src/Haskoin/Store/Logic/Layered.hs b/src/Haskoin/Store/Logic/Layered.hs new file mode 100644 --- /dev/null +++ b/src/Haskoin/Store/Logic/Layered.hs @@ -0,0 +1,792 @@ +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wno-ambiguous-fields #-} + +-- | +-- Module : Haskoin.Store.Logic.Layered +-- Copyright : (c) Haskoin Developers +-- License : MIT +-- Maintainer : jprupp@protonmail.ch +-- Stability : experimental +-- Portability : POSIX +-- +-- Rules to import and revert blocks and transactions in the layered layout +-- of the database (@docs\/layered-database.md@), in which the mempool is +-- kept apart from the chain. These are the rules that the block store +-- imports with. They do what "Haskoin.Store.Logic" did for the layout of +-- version 20, with the same functions, the same results and the same +-- errors, which is how the block store moved from one to the other, and +-- how the tests compare the two. +-- +-- = Two sets of rules +-- +-- __The chain__ has one door. 'importBlock' and 'revertBlock' are the only +-- functions here that write to the column families of the chain, and what +-- they write depends on the block and on those column families alone. A +-- block is imported the same way whether or not the store had seen its +-- transactions before, as during the initial sync: every output it spends +-- must be unspent in the chain, or the block is refused. +-- +-- __The mempool__ is a set of transactions, each with its keys in the +-- mempool area ('mempoolRecords'). A transaction enters by having its keys +-- written and leaves by having them deleted; nothing else is read or +-- changed, and nothing is written to the chain. What is left of the rules +-- is the checks: that the outputs a transaction spends exist and are +-- unspent, in the chain or in the mempool, and what it replaces. +-- +-- The two meet in three places. A block takes the transactions it confirms +-- out of the mempool, and deletes those that conflict with it. A reverted +-- block gives its transactions back to the mempool. And a mempool +-- transaction may spend outputs of the chain, which the chain goes on +-- listing as unspent: only the mempool area says otherwise. +-- +-- = Same answers as version 20 +-- +-- For any sequence of blocks and transactions, these rules leave the +-- database that "Haskoin.Store.Logic" followed by +-- "Haskoin.Store.Database.Migrate" leaves, key for key, and each step gives +-- the same result. The tests check that for random sequences. There is one +-- difference by design. A block that spends an output of an unconfirmed +-- transaction is refused here, because that output is not in the chain; +-- version 20 imports it, since its indices do not tell the two apart. +module Haskoin.Store.Logic.Layered + ( initBest, + revertBlock, + importBlock, + newMempoolTx, + deleteUnconfirmedTx, + ) +where + +import Control.Monad + ( forM, + forM_, + guard, + unless, + void, + when, + zipWithM_, + ) +import Data.ByteString qualified as B +import Data.Either (rights) +import Data.Functor ((<&>)) +import Data.HashMap.Strict qualified as M +import Data.HashSet qualified as H +import Data.IntMap.Strict qualified as I +import Data.List (nub) +import Data.Maybe + ( catMaybes, + fromMaybe, + isJust, + isNothing, + mapMaybe, + ) +import Data.Serialize (encode) +import Data.Text (Text) +import Data.Word (Word32, Word64) +import Haskoin + ( Address, + Block (..), + BlockHash, + BlockHeader (..), + BlockNode (..), + Ctx, + Network (..), + OutPoint (..), + Tx (..), + TxHash, + TxIn (..), + TxOut (..), + blockHashToHex, + computeSubsidy, + eitherToMaybe, + genesisBlock, + genesisNode, + headerHash, + isGenesis, + nullOutPoint, + scriptToAddressBS, + txHash, + txHashToHex, + ) +import Haskoin.Node (LogLevel (..), logAt) +import Haskoin.Store.Common (nub', sortTxs) +import Haskoin.Store.Data +import Haskoin.Store.Database.Mempool (MemRecords (..), mempoolRecords) +import Haskoin.Store.Database.Types (MemAddrKey (..), MemAddrVal (..), MemSummary (..)) +import Haskoin.Store.Database.Writer +import Haskoin.Store.Logic (ImportException (..)) +import UnliftIO (throwIO) + +------------------------------------------------------------------------------- +-- Reading +------------------------------------------------------------------------------- + +-- | Log a message with the logger of the writer. +logDebug, logError :: Writer -> Text -> IO () +logDebug wr = logAt LevelDebug (writerLogger wr) +logError wr = logAt LevelError (writerLogger wr) + +-- | Address of an output script, if it has one on the network. +scriptAddress :: Writer -> B.ByteString -> Maybe Address +scriptAddress wr = eitherToMaybe . scriptToAddressBS (writerNet wr) (writerCtx wr) + +-- | Data of a confirmed transaction, with the spenders of its outputs that +-- are in blocks. Version 20 kept the bodies of deleted transactions in the +-- same place; they do not count. +chainTx :: Writer -> TxHash -> IO (Maybe TxData) +chainTx wr h = + getTxData wr h <&> \case + Just td | not td.deleted -> Just td + _ -> Nothing + +-- | Data of a transaction that is in the mempool or in the chain, without +-- the mempool spenders of its outputs. +activeBody :: Writer -> TxHash -> IO (Maybe TxData) +activeBody wr h = getMempoolTx wr h >>= maybe (chainTx wr h) (return . Just) + +-- | Data of a transaction that is in the mempool or in the chain, with every +-- spender of its outputs, in blocks and in the mempool. +activeTx :: Writer -> TxHash -> IO (Maybe TxData) +activeTx wr h = activeBody wr h >>= mapM spent + where + spent td = do + ms <- getMempoolSpenders wr h (length td.tx.outputs) + -- those of blocks are under keys of their own, and only a confirmed + -- transaction can have any + cs <- if confirmed td.block then getChainSpenders wr h (length td.tx.outputs) else return I.empty + return (td :: TxData) {spenders = I.union cs ms} + +-- | An output that a new mempool transaction may spend: one that the chain +-- has as unspent, or one of a mempool transaction, that no mempool +-- transaction spends. +spendable :: Writer -> OutPoint -> IO (Maybe Unspent) +spendable wr p = + getMempoolSpender wr p >>= \case + Just _ -> return Nothing + Nothing -> + getUnspent wr p >>= \case + Just u -> return (Just u) + Nothing -> (>>= output) <$> getMempoolTx wr p.hash + where + output td = unspentOutput wr td.block p <$> getTxOut p.index td.tx + +-- | An output as an unspent output, given the position of its transaction. +unspentOutput :: Writer -> BlockRef -> OutPoint -> TxOut -> Unspent +unspentOutput wr br p o = + Unspent + { block = br, + outpoint = p, + value = o.value, + script = o.script, + address = scriptAddress wr o.script + } + +-- | Input that spends an output, in the mempool or in a block. +spenderOf :: Writer -> OutPoint -> IO (Maybe Spender) +spenderOf wr p = getMempoolSpender wr p >>= maybe (getChainSpender wr p) (return . Just) + +-- | Data of the best block. Throws 'BestBlockNotFound' if there is none. +bestBlockData :: Writer -> IO BlockData +bestBlockData wr = do + h <- + getBestBlock wr >>= \case + Nothing -> do + logError wr "Best block unknown" + throwIO BestBlockNotFound + Just h -> return h + getBlock wr h >>= \case + Nothing -> do + logError wr "Best block not found" + throwIO BestBlockNotFound + Just b -> return b + +------------------------------------------------------------------------------- +-- Blocks +------------------------------------------------------------------------------- + +-- | Import the genesis block if the database has no best block yet. +initBest :: Writer -> IO () +initBest wr = do + logDebug wr "Initializing best block" + let net = writerNet wr + m <- getBestBlock wr + when (isNothing m) . void $ do + logDebug wr "Importing Genesis block" + importBlock wr (genesisBlock net) (genesisNode net) + +-- | Check that a block builds on the best block, or that it is the genesis block +-- of an empty database. +checkNewBlock :: Writer -> Block -> BlockNode -> IO () +checkNewBlock wr b n = + getBestBlock wr >>= \case + Nothing + | isGenesis n -> return () + | otherwise -> do + logError wr $ "Cannot import non-genesis block: " <> blockHashToHex (headerHash b.header) + throwIO BestBlockNotFound + Just h + | b.header.prev == h -> return () + | otherwise -> do + logError wr $ "Block does not build on head: " <> blockHashToHex (headerHash b.header) + throwIO PrevBlockNotBest + +-- | Import a block that builds on the best block, and make it the best block. +-- Returns its data and the data of its transactions. +-- +-- The block goes into the chain's column families as it would into those of +-- a store with an empty mempool. Before that, the mempool gives way: the +-- transactions of the block that were in it leave it, and the mempool +-- transactions that spend an output that the block spends are deleted, with +-- their descendants. +importBlock :: Writer -> Block -> BlockNode -> IO (BlockData, [TxData]) +importBlock wr b n = do + checkNewBlock wr b n + let net = writerNet wr + subsidy = computeSubsidy net n.height + bs <- getBlocksAtHeight wr n.height + setBlocksAtHeight wr (nub (headerHash n.header : bs)) n.height + setBest wr (headerHash n.header) + tds <- importTxs wr n b.txs + let bd = + BlockData + { height = n.height, + main = True, + work = n.work, + header = n.header, + size = fromIntegral (B.length (encode b)), + txs = map txHash b.txs, + weight = if net.segWit then w else 0, + subsidy = subsidy, + fee = sum $ map txDataFee tds, + outputs = ts_out_val + } + insertBlock wr bd + logDebug wr $ "Finished importing block: " <> blockHashToHex (headerHash n.header) + return (bd, tds) + where + ts_out_val = + sum $ map (sum . map (.value) . (.outputs)) (drop 1 b.txs) + w = + let f t = (t :: Tx) {witness = []} + b' = (b :: Block) {txs = map f b.txs} + x = B.length (encode b) + s = B.length (encode b') + in fromIntegral $ s * 3 + x + +-- | Import the transactions of a block, in dependency order, after deleting +-- the mempool transactions that conflict with them. +importTxs :: Writer -> BlockNode -> [Tx] -> IO [TxData] +importTxs wr bn txns = do + mapM_ (freeOutputs . snd) (reverse txs) + mapM (uncurry action) txs + where + txs = sortTxs txns + br i = BlockRef {height = bn.height, position = i} + blockTime = fromIntegral bn.header.timestamp + freeOutputs tx = getConflicts wr True False tx >>= mapM_ (deleteSingleTx wr . txHash) + action i tx = + getMempoolTx wr (txHash tx) >>= \case + Just td -> do + -- it leaves the mempool, and with it the time at which this + -- store first saw it: in the chain its time is that of its + -- block, like that of a transaction that was never in the + -- mempool, so that the record is the same on every store + removeMempoolTx wr td + td' <- importChainTx wr (br i) blockTime tx + updateSpendersRBF wr tx + return td' + Nothing -> + chainTx wr (txHash tx) >>= \case + Just td -> moveChainTx wr td (br i) blockTime + Nothing -> importChainTx wr (br i) blockTime tx + +-- | Import a transaction of a block into the chain, with the time of the +-- block. Throws 'Orphan' if an output that it spends is not unspent in the +-- chain. +-- +-- = Why the time of the block +-- +-- What the chain's column families hold is to follow from the chain and +-- from nothing else: the same bytes on every store that has the same +-- blocks, whatever each of them saw before. The time of a transaction was +-- the one thing in them that did not. A store kept the time at which it +-- first saw a transaction in its mempool when a block confirmed it, so two +-- stores had two times for it, a store that synced later had the time of +-- the block, and the stores of a fleet gave different answers about the +-- same confirmed transaction. The time of first sight is still what a +-- transaction has while it is in the mempool, where it is the store's own, +-- or the pool's in a fleet. +importChainTx :: Writer -> BlockRef -> Word64 -> Tx -> IO TxData +importChainTx wr br time tx = do + us <- forM (prevOuts tx) $ \p -> + getUnspent wr p >>= \case + Just u -> return u + Nothing -> do + logError wr $ "Attempted to import a tx missing UTXO: " <> txHashToHex (txHash tx) + throwIO Orphan + let td = prepareTxData False br time tx us + addChainTx wr td + return td + +-- | Give a confirmed transaction a new position in the chain: a block has a +-- transaction that is already confirmed. Only two coinbases of 2010 are, on +-- Bitcoin; the later one takes the place of the earlier, with the outputs +-- that are still unspent, as in the layout of version 20, and the time of +-- the later block. +moveChainTx :: Writer -> TxData -> BlockRef -> Word64 -> IO TxData +moveChainTx wr t new time = do + forM_ (txDataAddresses wr t) $ \a -> do + deleteAddrTx wr a TxRef {block = t.block, txid = h} + insertAddrTx wr a TxRef {block = new, txid = h} + forM_ (zip [0 ..] t.tx.outputs) $ \(i, _) -> + getUnspent wr (OutPoint h i) >>= mapM_ move + let td = (t :: TxData) {block = new, timestamp = time} + insertTx wr td + return td + where + h = txHash t.tx + move u = do + let u' = (u :: Unspent) {block = new} + insertUnspent wr u' + forM_ u.address $ \a -> deleteAddrUnspent wr a u >> insertAddrUnspent wr a u' + +-- | Revert the best block: make its parent the best block, mark it as not in +-- the main chain, take its transactions out of the chain and give them to +-- the mempool, and delete its coinbase with whatever spends it. Throws +-- 'BlockNotBest' if the block is not the best block. +revertBlock :: Writer -> BlockHash -> IO () +revertBlock wr bh = do + bd <- + bestBlockData wr >>= \b -> + if headerHash b.header == bh + then return b + else do + logError wr $ "Cannot revert non-head block: " <> blockHashToHex bh + throwIO BlockNotBest + tds <- mapM inChain bd.txs + setBest wr bd.header.prev + insertBlock wr bd {main = False} + case tds of + [] -> return () + coinbase : rest -> do + let returned = M.fromList [(txHash td.tx, td) | td <- rest] + -- the transactions that go back to the mempool, each after the + -- transactions that it spends + ordered = filter ((`M.member` returned) . txHash) (map snd (sortTxs (map (.tx) tds))) + -- out of the chain, each after the transactions that spend it + forM_ (reverse ordered) (leave . txHash) + -- into the mempool, at the time that each had in the chain, which is + -- that of the block: the time at which a store first saw it is not + -- kept past its confirmation, and every store gives it the same + -- time this way. The coinbase is still in the chain: a transaction that spends it has all its + -- parents while its flag is worked out, as in the layout of version 20 + forM_ (mapMaybe ((`M.lookup` returned) . txHash) ordered) $ \td -> do + rbf <- isRBF wr td.tx + addMempoolTx wr td.timestamp (td :: TxData) {rbf = rbf} + updateSpendersRBF wr td.tx + -- a coinbase cannot be in the mempool: it is deleted, and so is + -- everything that spends it + spenders <- getMempoolSpenders wr (txHash coinbase.tx) (length coinbase.tx.outputs) + forM_ (nub' (map (.txid) (I.elems spenders))) $ \h -> + getChain wr True False h >>= mapM_ (deleteSingleTx wr . txHash) + -- and forgotten: nothing is kept of a transaction that leaves the + -- store unconfirmed + leave (txHash coinbase.tx) + where + inChain h = + chainTx wr h >>= \case + Just td -> return td + Nothing -> do + logDebug wr $ "Tx not found: " <> txHashToHex h + throwIO TxNotFound + -- take a transaction that nothing in the chain spends out of the chain + leave h = do + td <- inChain h + spent <- getChainSpenders wr h (length td.tx.outputs) + unless (I.null spent) $ do + logError wr $ "Tried to revert spent tx: " <> txHashToHex h + throwIO TxSpent + removeChainTx wr td + +------------------------------------------------------------------------------- +-- The chain's column families +------------------------------------------------------------------------------- + +-- | Data of a new transaction, from its replace-by-fee flag, position, time and +-- the outputs it spends. +prepareTxData :: Bool -> BlockRef -> Word64 -> Tx -> [Unspent] -> TxData +prepareTxData rbf br tt tx us = + TxData + { block = br, + tx = tx, + prevs = ps, + deleted = False, + rbf = rbf, + timestamp = tt, + spenders = I.empty + } + where + mkprv Unspent {..} = Prev script value + ps = I.fromList $ zip [0 ..] $ map mkprv us + +-- | Change the balance of an address in the chain. An address whose balance +-- goes back to nothing, as when the only block that paid it is reverted, has +-- none. +modifyBalance :: Writer -> Address -> (Balance -> Balance) -> IO () +modifyBalance wr a f = do + b <- f . fromMaybe (zeroBalance a) <$> getBalance wr a + if nullBalance b then deleteBalance wr a else setBalance wr b + +-- | Subtract, or stop: no count or amount of the chain goes below zero. +less :: String -> Word64 -> Word64 -> Word64 +less what x y + | y > x = error $ "The " <> what <> " of an address would go below zero" + | otherwise = x - y + +-- | Add a confirmed transaction to every index of the chain. Every output +-- that it spends must be unspent in the chain. +addChainTx :: Writer -> TxData -> IO () +addChainTx wr td = do + forM_ (txDataAddresses wr td) $ \a -> do + insertAddrTx wr a TxRef {block = td.block, txid = h} + modifyBalance wr a $ \b -> (b :: Balance) {txs = b.txs + 1} + forM_ (zip [0 ..] td.tx.outputs) $ \(i, o) -> do + let u = unspentOutput wr td.block (OutPoint h i) o + insertUnspent wr u + forM_ u.address $ \a -> do + insertAddrUnspent wr a u + modifyBalance wr a $ \b -> + (b :: Balance) + { confirmed = b.confirmed + o.value, + utxo = b.utxo + 1, + received = b.received + o.value + } + zipWithM_ spend [0 ..] (prevOuts td.tx) + insertTx wr td + where + h = txHash td.tx + spend ix p = do + u <- + getUnspent wr p >>= \case + Just u -> return u + Nothing -> error $ "Could not find UTXO to spend: " <> show p + deleteUnspent wr p + -- under the key of the output: the record of the transaction that + -- made it is written once, when it is confirmed, and is not read + -- here either + insertSpender wr p (Spender h ix) + forM_ u.address $ \a -> do + deleteAddrUnspent wr a u + modifyBalance wr a $ \b -> + (b :: Balance) + { confirmed = less "confirmed balance" b.confirmed u.value, + utxo = less "count of unspent outputs" b.utxo 1 + } + +-- | Take a confirmed transaction that nothing in the chain spends out of +-- every index of the chain, and make the outputs that it spent unspent +-- again. +removeChainTx :: Writer -> TxData -> IO () +removeChainTx wr td = do + forM_ (txDataAddresses wr td) $ \a -> do + deleteAddrTx wr a TxRef {block = td.block, txid = h} + modifyBalance wr a $ \b -> (b :: Balance) {txs = less "count of transactions" b.txs 1} + forM_ (zip [0 ..] td.tx.outputs) $ \(i, o) -> do + let p = OutPoint h i + u = unspentOutput wr td.block p o + deleteUnspent wr p + forM_ u.address $ \a -> do + deleteAddrUnspent wr a u + modifyBalance wr a $ \b -> + (b :: Balance) + { confirmed = less "confirmed balance" b.confirmed o.value, + utxo = less "count of unspent outputs" b.utxo 1, + received = less "amount received" b.received o.value + } + forM_ (prevOuts td.tx) $ \p -> do + parent <- + chainTx wr p.hash >>= \case + Just t -> return t + Nothing -> error $ "Could not find tx data: " <> show p.hash + let o = fromMaybe (error ("Could not find output: " <> show p)) (getTxOut p.index parent.tx) + u = unspentOutput wr parent.block p o + deleteSpender wr p + insertUnspent wr u + forM_ u.address $ \a -> do + insertAddrUnspent wr a u + modifyBalance wr a $ \b -> (b :: Balance) {confirmed = b.confirmed + o.value, utxo = b.utxo + 1} + deleteTxData wr h + where + h = txHash td.tx + +------------------------------------------------------------------------------- +-- The mempool area +------------------------------------------------------------------------------- + +-- | Import a transaction into the mempool with the time it arrived. Returns +-- 'False' if it is already known. +-- +-- Conflicting unconfirmed transactions are deleted together with their +-- descendants if the network has replace-by-fee; otherwise the transaction is +-- rejected with 'DoubleSpend'. Throws an 'ImportException' if the transaction is +-- invalid, for example if it spends unknown outputs. +newMempoolTx :: Writer -> Tx -> UnixTime -> IO Bool +newMempoolTx wr tx w = + activeBody wr (txHash tx) >>= \case + Just _ -> return False + Nothing -> do + -- Check everything before writing, so that a rejected transaction + -- leaves the mempool as it was. + replaced <- getConflicts wr True True tx + checkNewTx wr (map txHash replaced) tx + mapM_ (deleteSingleTx wr . txHash) replaced + rbf <- isRBF wr tx + us <- forM (prevOuts tx) $ \p -> + spendable wr p >>= \case + Just u -> return u + Nothing -> do + logError wr $ "Attempted to import a tx missing UTXO: " <> txHashToHex (txHash tx) + throwIO Orphan + addMempoolTx wr w (prepareTxData rbf (MemRef w) w tx us) + return True + +-- | Delete an unconfirmed transaction and its descendants. If the flag is set and +-- the network has no replace-by-fee, throw 'DoubleSpend' instead. Does nothing if +-- the transaction is not found. +deleteUnconfirmedTx :: Writer -> Bool -> TxHash -> IO () +deleteUnconfirmedTx wr rbfcheck th = + activeBody wr th >>= \case + Just _ -> getChain wr True rbfcheck th >>= mapM_ (deleteSingleTx wr . txHash) + Nothing -> logDebug wr $ "Not found or already deleted: " <> txHashToHex th + +-- | Write the keys of a transaction to the mempool area, with the time it +-- entered the mempool. The body goes in at that mempool position and without +-- spenders, whatever it had. +addMempoolTx :: Writer -> UnixTime -> TxData -> IO () +addMempoolTx wr time td = do + insertMempoolTx wr r.body + forM_ r.spends (uncurry (insertMempoolSpender wr)) + forM_ r.addresses (uncurry (insertMempoolAddr wr)) + adjustSummaries wr (+) r + addToMempool wr r.txid r.time + where + r = mempoolRecords (writerNet wr) (writerCtx wr) time td + +-- | Delete the keys of a mempool transaction, given its body, from the +-- mempool area. +removeMempoolTx :: Writer -> TxData -> IO () +removeMempoolTx wr td = do + deleteMempoolTx wr r.txid + forM_ r.spends (deleteMempoolSpender wr . fst) + forM_ r.addresses (deleteMempoolAddr wr . fst) + adjustSummaries wr (less "mempool summary") r + deleteFromMempool wr r.txid + where + time = case td.block of + MemRef t -> t + BlockRef {} -> td.timestamp + r = mempoolRecords (writerNet wr) (writerCtx wr) time td + +-- | Add what a transaction does at each address it touches to the summary +-- of the address, or take it off again, given how to combine a number of +-- the summary with one of the transaction. +-- +-- Everything is in the entries of the transaction but one thing: whether an +-- output that it spends was made by the mempool, and whether an output that +-- it makes is spent by the mempool, which is what 'both' counts. Each is a +-- read by key of what another transaction wrote. An output is counted in +-- 'both' while both of its transactions are in the mempool, so it is added +-- by the second of them to arrive and taken off by the first to leave, +-- whichever that is. +adjustSummaries :: Writer -> (Word64 -> Word64 -> Word64) -> MemRecords -> IO () +adjustSummaries wr op r = do + deltas <- forM r.addresses $ \case + (MemAddrTxKey a _ _, _) -> return (a, MemSummary 1 0 0 0 0 0 0) + (MemAddrSpentKey a p, MemAddrSpentVal v) -> do + made <- inMempool wr p.hash + return (a, if made then MemSummary 0 0 0 v 1 v 1 else MemSummary 0 0 0 v 1 0 0) + (MemAddrOutKey a _ p, MemAddrOutVal v _) -> do + taken <- isJust <$> getMempoolSpender wr p + return (a, if taken then MemSummary 0 v 1 0 0 v 1 else MemSummary 0 v 1 0 0 0 0) + (k, _) -> error ("Not an entry of a transaction: " <> show k) + forM_ (M.toList (M.fromListWith plus deltas)) $ \(a, d) -> do + old <- + getMempoolAddr wr (MemAddrSumKey a) <&> \case + Just (MemAddrSumVal s) -> s + _ -> zero + let new = combine op old d + if new == zero + then deleteMempoolAddr wr (MemAddrSumKey a) + else insertMempoolAddr wr (MemAddrSumKey a) (MemAddrSumVal new) + where + zero = MemSummary 0 0 0 0 0 0 0 + plus = combine (+) + combine f x y = + MemSummary + { txs = f x.txs y.txs, + paid = f x.paid y.paid, + paidCount = f x.paidCount y.paidCount, + spent = f x.spent y.spent, + spentCount = f x.spentCount y.spentCount, + both = f x.both y.both, + bothCount = f x.bothCount y.bothCount + } + +-- | Delete a mempool transaction that nothing spends. Nothing is kept of +-- it. Throws 'TxSpent' if something spends it. +-- +-- Until version 22 its body was kept, marked as deleted, and the API +-- returned it with that mark. Clients that did not read the mark took a +-- replaced transaction for a payment, each store had its own set of them, +-- which a fleet cannot answer from, and nothing ever removed them. What +-- the store needs of them, not to fetch a transaction again that it just +-- deleted, it remembers for a while in memory +-- ("Haskoin.Store.BlockStore"). +deleteSingleTx :: Writer -> TxHash -> IO () +deleteSingleTx wr th = + getMempoolTx wr th >>= \case + Nothing -> do + logError wr $ "Already deleted: " <> txHashToHex th + throwIO TxNotFound + Just td -> do + spenders <- getMempoolSpenders wr th (length td.tx.outputs) + if I.null spenders + then do + logDebug wr $ "Deleting tx: " <> txHashToHex th + removeMempoolTx wr td + else do + logError wr $ "Tried to delete spent tx: " <> txHashToHex th + throwIO TxSpent + +-- | Check a transaction that will replace these ones. Outputs that they spend +-- count as unspent, and outputs that they create as missing. +checkNewTx :: Writer -> [TxHash] -> Tx -> IO () +checkNewTx wr replaced tx = do + when (unique_inputs < length tx.inputs) $ do + logError wr $ "Transaction spends same output twice: " <> txHashToHex (txHash tx) + throwIO DuplicatePrevOutput + prevs <- mapM prev_output (prevOuts tx) + when (any isNothing prevs) $ do + logError wr $ "Orphan: " <> txHashToHex (txHash tx) + throwIO Orphan + when (isCoinbaseTx tx) $ do + logError wr $ "Coinbase cannot be imported into mempool: " <> txHashToHex (txHash tx) + throwIO UnexpectedCoinbase + when (outputs > sum (map (.value) (catMaybes prevs))) $ do + logError wr $ "Insufficient funds for tx: " <> txHashToHex (txHash tx) + throwIO InsufficientFunds + where + prev_output op + | op.hash `elem` replaced = return Nothing + | otherwise = (>>= getTxOut op.index . (.tx)) <$> activeBody wr op.hash + outputs = sum (map (.value) tx.outputs) + unique_inputs = length (nub' (map (.outpoint) tx.inputs)) + +-- | Transactions that spend the same outputs as this one, with their +-- descendants, in an order in which they can be deleted. The first flag +-- refuses confirmed transactions, and the second refuses any on networks +-- without replace-by-fee. +getConflicts :: Writer -> Bool -> Bool -> Tx -> IO [Tx] +getConflicts wr memonly rbfcheck tx = do + let prevs = prevOuts tx + unspents <- mapM (spendable wr) prevs + let spents = [p | (p, Nothing) <- zip prevs unspents] + spndrs <- catMaybes <$> mapM (spenderOf wr) spents + let txids = H.fromList $ filter (/= txHash tx) $ map (.txid) spndrs + chains <- mapM (getChain wr memonly rbfcheck) (H.toList txids) + return . reverse . map snd . sortTxs . M.elems $ + M.fromList [(txHash t, t) | t <- concat chains] + +-- | A transaction and all its descendants, in an order in which they can be +-- deleted: spenders first. +getChain :: Writer -> Bool -> Bool -> TxHash -> IO [Tx] +getChain wr memonly rbfcheck th' = + sort_clean <$> go M.empty (H.singleton th') + where + sort_clean = reverse . map snd . sortTxs + get_tx th = + activeTx wr th >>= \case + Nothing -> do + logDebug wr $ "Transaction not found: " <> txHashToHex th + return Nothing + Just td + | memonly && confirmed td.block -> do + logError wr $ "Transaction already confirmed: " <> txHashToHex th + throwIO TxConfirmed + | rbfcheck -> + if (writerNet wr).replaceByFee + then return $ Just td + else do + logError wr $ "Double-spending transaction: " <> txHashToHex th + throwIO DoubleSpend + | otherwise -> return $ Just td + go txm pdg = do + let ths = filter (not . (`M.member` txm)) (H.toList pdg) + tds <- catMaybes <$> mapM get_tx ths + let txmn = M.fromList $ fmap (\d -> (txHash d.tx, d.tx)) tds + spds = concatMap (map (.txid) . I.elems . (.spenders)) tds + pdg' = H.fromList spds + txm' = txmn <> txm + if H.null pdg' + then return $ M.elems txm' + else go txm' pdg' + +-- | Whether a mempool transaction can be replaced by fee: it signals BIP125 +-- in one of its inputs, or it spends an unconfirmed transaction that can be +-- replaced. Always 'False' on networks without replace-by-fee. +isRBF :: Writer -> Tx -> IO Bool +isRBF wr tx + | not (writerNet wr).replaceByFee = return False + | any ((< 0xffffffff - 1) . (.sequence)) tx.inputs = return True + | otherwise = ck (nub' $ map (.outpoint.hash) tx.inputs) + where + ck [] = return False + ck (h : hs') = + activeBody wr h >>= \case + Nothing -> return False + Just t + | confirmed t.block -> ck hs' + | t.rbf -> return True + | otherwise -> ck hs' + +-- | Mempool transactions inherit BIP125 signalling from unconfirmed parents +-- only, so their flag can change when a parent is confirmed or goes back to +-- the mempool. Correct the flags of the mempool transactions that spend the +-- outputs of a transaction, and of theirs in turn. +updateSpendersRBF :: Writer -> Tx -> IO () +updateSpendersRBF wr tx = do + spenders <- getMempoolSpenders wr (txHash tx) (length tx.outputs) + forM_ (nub' (map (.txid) (I.elems spenders))) $ \h -> + getMempoolTx wr h >>= mapM_ update + where + update s = do + rbf <- isRBF wr s.tx + when (rbf /= s.rbf) $ do + insertMempoolTx wr (s :: TxData) {rbf = rbf} + updateSpendersRBF wr s.tx + +------------------------------------------------------------------------------- +-- Transactions +------------------------------------------------------------------------------- + +-- | Output of a transaction at an index, or 'Nothing' if out of range. +getTxOut :: Word32 -> Tx -> Maybe TxOut +getTxOut i tx = do + guard (fromIntegral i < length tx.outputs) + return $ tx.outputs !! fromIntegral i + +-- | Addresses that a transaction is indexed under: those of its outputs and +-- of the outputs that it spends. An output script counts only when it has +-- an address on the network. +txDataAddresses :: Writer -> TxData -> [Address] +txDataAddresses wr t = + nub' . rights $ + map (scriptToAddressBS net ctx . (.script)) (I.elems t.prevs) + <> map (scriptToAddressBS net ctx . (.script)) t.tx.outputs + where + net = writerNet wr :: Network + ctx = writerCtx wr :: Ctx + +-- | Outputs spent by a transaction, without the null outpoint of a coinbase. +prevOuts :: Tx -> [OutPoint] +prevOuts tx = filter (/= nullOutPoint) (map (.outpoint) tx.inputs) diff --git a/src/Haskoin/Store/Manager.hs b/src/Haskoin/Store/Manager.hs --- a/src/Haskoin/Store/Manager.hs +++ b/src/Haskoin/Store/Manager.hs @@ -1,10 +1,3 @@ -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedRecordDot #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoFieldSelectors #-} - -- | -- Module : Haskoin.Store.Manager -- Copyright : (c) Haskoin Developers @@ -15,11 +8,12 @@ -- -- Wires the components of a store together: the RocksDB database, the -- peer-to-peer node, the block store that imports data, and the optional Redis --- cache with its writer process. Node events are forwarded to the block store --- and turned into 'StoreEvent's. +-- cache. Node events are forwarded to the block store and turned into +-- 'StoreEvent's, which the cache follows. +-- -- Keeping the wiring in one place means each component only knows about the --- interfaces it uses: the block store does not know about the cache, and the --- node does not know about either. 'withStore' starts them in dependency order +-- interfaces it uses: the node does not know about the block store, and the +-- block store does not know about the cache. 'withStore' starts them in dependency order -- and stops them all together. module Haskoin.Store.Manager ( StoreConfig (..), @@ -28,15 +22,14 @@ ) where -import Control.Monad (unless) -import Control.Monad.Cont - ( ContT (..), - runContT, - ) -import Control.Monad.Reader (ReaderT (ReaderT), runReaderT) -import Control.Monad.Trans (lift) +import Control.Monad (forM_, unless, when) +import Data.ByteString (ByteString) +import Data.ByteString.Char8 qualified as C +import Data.Serialize (Serialize, decode) +import Data.String.Conversions (cs) import Data.Time.Clock (NominalDiffTime) -import Data.Word (Word32) +import Data.Word (Word32, Word64) +import Database.Redis qualified as Redis import Haskoin ( BlockHash (..), Ctx, @@ -57,6 +50,7 @@ import Haskoin.Node ( Chain, ChainEvent (..), + LogLevel (..), Logger, Node (..), NodeConfig (..), @@ -64,6 +58,7 @@ PeerEvent (..), PeerMgr, WithConnection, + logAt, withNode, withSource, ) @@ -79,48 +74,46 @@ blockStoreTxSTM, withBlockStore, ) -import Haskoin.Store.Cache - ( CacheConfig (..), - CacheWriter, - cacheNewBlock, - cacheNewTx, - cacheSyncMempool, - cacheWriter, - connectRedis, - newCacheMetrics, - ) +import Haskoin.Store.Cache (Cache, CacheConfig (..), cachePrefix, withCache) import Haskoin.Store.Common ( StoreEvent (..), loopForever, ) +import Haskoin.Store.Database.Migrate (Migration (..), upgradeDatabase) import Haskoin.Store.Database.Reader ( DatabaseReader (..), - DatabaseReaderT, createDataMetrics, - withDatabaseReader, + withLayeredReader, ) +import Haskoin.Store.Fleet.Member + ( Member, + MemberConfig (..), + memberCacheLoop, + memberEvents, + memberForget, + memberLoop, + newMember, + noteBest, + ) +import Haskoin.Store.Fleet.Redis (FleetEvent (..)) import NQE ( Inbox, - Process (..), Publisher, + publish, publishSTM, receive, - withProcess, withPublisher, withSubscription, ) import Network.Socket (SockAddr (..)) import System.Metrics.StatsD +import System.Random (randomIO) import UnliftIO - ( MonadIO, - MonadUnliftIO, - STM, + ( STM, atomically, - liftIO, link, withAsync, ) -import UnliftIO.Concurrent (threadDelay) -- | Store mailboxes. Handles to the running components of a store, given by -- 'withStore'. @@ -133,8 +126,17 @@ block :: !BlockStore, -- | database reader db :: !DatabaseReader, - -- | cache configuration, if Redis is configured - cache :: !(Maybe CacheConfig), + -- | cache of extended public keys, if Redis is configured and the store + -- is not a member of a fleet + cache :: !(Maybe Cache), + -- | the store as a member of a fleet, if it is one + fleet :: !(Maybe Member), + -- | what the store tells its clients: new best blocks and changes of + -- the mempool. For a store alone they are its own, those that the + -- block store publishes. + -- For a member of a fleet they are those of the fleet, read from the + -- Redis that it shares, so that every server tells the same. + events :: !(Publisher StoreEvent), -- | store events are published here pub :: !(Publisher StoreEvent), -- | network constants @@ -155,7 +157,8 @@ db :: !FilePath, -- | network constants net :: !Network, - -- | Redis cache configuration + -- | Redis URL for the cache of extended public keys ("Haskoin.Store.Cache"); + -- 'Nothing' for no cache, an empty URL for the local Redis redis :: !(Maybe String), -- | Secp256k1 context ctx :: !Ctx, @@ -163,14 +166,25 @@ initGap :: !Word32, -- | gap for extended public keys gap :: !Word32, - -- | cache xpubs with more than this many used addresses + -- | cache xpubs with at least this many used addresses redisMinAddrs :: !Int, - -- | maximum number of keys in Redis cache - redisMaxKeys :: !Integer, + -- | or with at least this many transactions in their addresses + redisMinTxs :: !Int, + -- | evict the least recently used xpubs from the cache past this many + redisMaxXPubs :: !Int, -- | do not index new mempool transactions noMempool :: !Bool, -- | wipe mempool when starting wipeMempool :: !Bool, + -- | answer as one of a fleet of stores that share the Redis of 'redis': + -- every store of the fleet then gives the same answer to the same + -- request, from the block that they agree on and the mempool that they + -- share ("Haskoin.Store.Fleet.Member"). The cache of extended public + -- keys of a store alone ("Haskoin.Store.Cache") is not used then: its + -- entries follow each store's own database, which is what a fleet does + -- not answer from. A fleet has one of its own + -- ("Haskoin.Store.Fleet.XPub"), under the same three settings. + fleet :: !Bool, -- | sync mempool from peers syncMempool :: !Bool, -- | blocks to request from the syncing peer in one batch @@ -181,13 +195,11 @@ peerTimeout :: !NominalDiffTime, -- | disconnect peer if it has been connected this long maxPeerLife :: !NominalDiffTime, - -- | connect to peers using the function 'withConnection' + -- | connect to peers using the function 'Haskoin.Node.withConnection' connect :: !(SockAddr -> WithConnection), -- | StatsD stats :: !(Maybe Stats), - -- | sync mempool against cache every this many seconds - redisSyncInterval :: !Int, - -- | database Bloom filters + -- | Bloom filters on the column families that are read by key bloom :: !Bool, -- | RocksDB max_open_files ('Nothing' = unlimited: every SST file's index -- and filter blocks stay resident for the life of the process) @@ -210,46 +222,151 @@ -- when the action returns, and an exception in any component is re-thrown in -- the calling thread. -- --- The database is opened first, then the node, the cache (if 'redis' is set) --- and the block store. +-- The database is opened first, then the node, the block store and the cache +-- (if 'redis' is set). withStore :: - (MonadUnliftIO m) => StoreConfig -> - (Store -> m a) -> - m a + (Store -> IO a) -> + IO a withStore cfg action = - connectDB cfg $ - ReaderT $ \db -> flip runContT return $ do - pub <- ContT withPublisher - node_pub <- ContT withPublisher - node_sub <- ContT $ withSubscription node_pub - node <- ContT $ withNode $ nodeCfg cfg db node_pub - cache_cfg <- ContT $ withCache cfg node.chain db pub - block_store <- ContT $ withBlockStore $ blockStoreCfg cfg node pub db - fwd <- ContT $ withAsync $ nodeForwarder block_store pub node_sub - link fwd - lift $ - action - Store - { peerMgr = node.peerMgr, - chain = node.chain, - block = block_store, - db = db, - cache = cache_cfg, - pub = pub, - net = cfg.net, - ctx = cfg.ctx - } + connectDB cfg $ \db -> + withPublisher $ \pub -> + withPublisher $ \node_pub -> + withSubscription node_pub $ \node_sub -> + withNode (nodeCfg cfg db node_pub) $ \node -> do + member <- storeMember cfg db + withBlockStore (blockStoreCfg cfg node pub db member) $ \block_store -> + withAsync (nodeForwarder block_store pub node_sub) $ \fwd -> do + link fwd + withStoreFleet cfg pub member . withStoreCache cfg db node.chain pub $ \cache -> + withFleetEvents cfg pub member $ \events -> + action $ + Store + { peerMgr = node.peerMgr, + chain = node.chain, + block = block_store, + db = db, + cache = cache, + fleet = member, + events = events, + pub = pub, + net = cfg.net, + ctx = cfg.ctx + } --- | Open the database described by the configuration and run an action with its reader. +-- | The store as a member of a fleet, if the configuration says that it is +-- one and has a Redis to share: under a name of its own, with a lease of +-- ten seconds, views of its last six blocks, and the store's limit on the +-- age of unconfirmed transactions. +storeMember :: StoreConfig -> DatabaseReader -> IO (Maybe Member) +storeMember cfg db = case (cfg.fleet, cfg.redis) of + (True, Just url) -> do + info <- + if null url + then return Redis.defaultConnectInfo + else either fail return (Redis.parseConnectInfo url) + conn <- Redis.checkedConnect info + name <- C.pack . show <$> (randomIO :: IO Word64) + Just + <$> newMember + MemberConfig + { prefix = cachePrefix cfg.net, + name, + lease = 10000, + depth = 6, + expiry = fromIntegral cfg.mempoolTimeout * 24 * 3600, + cacheMax = cfg.redisMaxXPubs, + cacheMinAddrs = cfg.redisMinAddrs, + cacheMinTxs = cfg.redisMinTxs, + stats = cfg.stats, + note = \level -> logAt level (withSource "Fleet" cfg.logger) + } + conn + db + _ -> return Nothing + +-- | Take the store's turns as a member of its fleet while an action runs, +-- if it is one: every two seconds, and whenever the best block changes. +-- Beside them, in a thread of its own, the member builds the entries of +-- the fleet's cache of extended public keys that requests asked for. +withStoreFleet :: StoreConfig -> Publisher StoreEvent -> Maybe Member -> IO a -> IO a +withStoreFleet _ _ Nothing action = action +withStoreFleet cfg pub (Just member) action = + withSubscription pub $ \sub -> + withAsync (memberLoop member (nextBlock sub) complain) $ \a -> + withAsync (memberCacheLoop member cacheComplain) $ \b -> link a >> link b >> action + where + -- until the next block, telling the member what the store deletes + nextBlock sub = + receive sub >>= \case + StoreBestBlock _ -> return () + StoreMempoolDelete h -> memberForget member [h] >> nextBlock sub + _ -> nextBlock sub + complain why = logAt LevelError (withSource "Fleet" cfg.logger) ("Could not take a turn: " <> cs why) + cacheComplain why = logAt LevelError (withSource "Fleet" cfg.logger) ("Could not cache an xpub: " <> cs why) + +-- | Run an action with the events that the store tells its clients. A +-- store alone tells its own. A member of a fleet tells those of the +-- fleet, which a thread reads from Redis for as long as the action runs. +withFleetEvents :: + StoreConfig -> + Publisher StoreEvent -> + Maybe Member -> + (Publisher StoreEvent -> IO a) -> + IO a +withFleetEvents _ pub Nothing action = action pub +withFleetEvents cfg _ (Just member) action = + withPublisher $ \shared -> + withAsync (memberEvents member False (tell shared) complain) $ \a -> link a >> action shared + where + tell shared event = forM_ (told event) (`publish` shared) + told = \case + FleetBlock h -> StoreBestBlock <$> hash h + FleetEntered h -> StoreMempoolNew <$> hash h + FleetLeft h -> StoreMempoolDelete <$> hash h + hash :: (Serialize x) => ByteString -> Maybe x + hash = either (const Nothing) Just . decode + complain why = logAt LevelError (withSource "Fleet" cfg.logger) ("Could not read the events: " <> cs why) + +-- | Run the cache while an action runs, if Redis is configured. +withStoreCache :: + StoreConfig -> + DatabaseReader -> + Chain -> + Publisher StoreEvent -> + (Maybe Cache -> IO a) -> + IO a +withStoreCache cfg db chain pub action = + case cfg.redis of + Nothing -> action Nothing + Just _ | cfg.fleet -> action Nothing + Just url -> + withCache + CacheConfig + { url = url, + minAddrs = cfg.redisMinAddrs, + minTxs = cfg.redisMinTxs, + maxXPubs = cfg.redisMaxXPubs, + stats = cfg.stats + } + db + chain + pub + (withSource "Cache" cfg.logger) + (action . Just) + +-- | Open the database described by the configuration, bring it to the +-- layout that the store runs on ('upgradeDatabase'), and run an action with +-- its reader. A database of version 20 has its mempool moved to an area of +-- its own here, once, before anything reads it; older stores refuse the +-- database from then on. connectDB :: - (MonadUnliftIO m) => StoreConfig -> - DatabaseReaderT m a -> - m a + (DatabaseReader -> IO a) -> + IO a connectDB cfg f = do - stats <- liftIO $ mapM createDataMetrics cfg.stats - withDatabaseReader + stats <- mapM createDataMetrics cfg.stats + withLayeredReader cfg.net cfg.ctx cfg.initGap @@ -261,7 +378,15 @@ cfg.maxWalSize cfg.blockCache stats - f + $ \db -> do + done <- upgradeDatabase (logAt LevelInfo (withSource "Database" cfg.logger)) db + when (done.moved > 0) $ + logAt LevelInfo (withSource "Database" cfg.logger) $ + "Moved " <> cs (show done.moved) <> " mempool transactions to their own area" + when (done.rewritten > 0) $ + logAt LevelInfo (withSource "Database" cfg.logger) $ + "Wrote the records of " <> cs (show done.rewritten) <> " confirmed transactions again, to be written once" + f db -- | Configuration of the block store, from the store configuration. blockStoreCfg :: @@ -269,8 +394,9 @@ Node -> Publisher StoreEvent -> DatabaseReader -> + Maybe Member -> BlockStoreConfig -blockStoreCfg cfg node pub db = +blockStoreCfg cfg node pub db member = BlockStoreConfig { chain = node.chain, peerMgr = node.peerMgr, @@ -280,6 +406,7 @@ ctx = cfg.ctx, noMempool = cfg.noMempool, wipeMempool = cfg.wipeMempool, + onBest = maybe (\_ -> return ()) noteBest member, syncMempool = cfg.syncMempool, blockWindow = cfg.blockWindow, mempoolTimeout = cfg.mempoolTimeout, @@ -314,82 +441,12 @@ logger = cfg.logger } --- | If Redis is configured, connect to it, start the cache writer, and pass the --- cache configuration to the action. Otherwise pass 'Nothing'. -withCache :: - (MonadUnliftIO m) => - StoreConfig -> - Chain -> - DatabaseReader -> - Publisher StoreEvent -> - (Maybe CacheConfig -> m a) -> - m a -withCache cfg chain db pub action = - case cfg.redis of - Nothing -> - action Nothing - Just redisurl -> do - conn <- connectRedis redisurl - metrics <- mapM (\s -> newCacheMetrics logger s conn db) cfg.stats - withSubscription pub $ \evts -> - let conf = c conn metrics - in withProcess (f conf) $ \p -> - cacheWriterProcesses - cfg.redisSyncInterval - evts - (getProcessMailbox p) - (action (Just conf)) - where - f conf cwinbox = runReaderT (cacheWriter conf cwinbox) db - logger = withSource "Cache" cfg.logger - c conn metrics = - CacheConfig - { redis = conn, - minAddrs = cfg.redisMinAddrs, - chain = chain, - maxKeys = cfg.redisMaxKeys, - metrics = metrics, - logger = logger - } - --- | Run the loop that feeds store events to the cache writer while the action runs. -cacheWriterProcesses :: - (MonadUnliftIO m) => - Int -> - Inbox StoreEvent -> - CacheWriter -> - m a -> - m a -cacheWriterProcesses interval evts cwm action = - withAsync (cacheWriterEvents interval evts cwm) $ \a1 -> link a1 >> action - --- | Forward store events to the cache writer, and ask it to sync the mempool --- every given number of seconds. -cacheWriterEvents :: (MonadUnliftIO m) => Int -> Inbox StoreEvent -> CacheWriter -> m () -cacheWriterEvents interval evts cwm = - withAsync mempool . const $ - loopForever $ - receive evts >>= \e -> - e `cacheWriterDispatch` cwm - where - mempool = loopForever $ do - threadDelay (interval * 1000 * 1000) - cacheSyncMempool cwm - --- | Tell the cache writer about new blocks and mempool changes. -cacheWriterDispatch :: (MonadIO m) => StoreEvent -> CacheWriter -> m () -cacheWriterDispatch (StoreBestBlock _) = cacheNewBlock -cacheWriterDispatch (StoreMempoolNew t) = cacheNewTx t -cacheWriterDispatch (StoreMempoolDelete t) = cacheNewTx t -cacheWriterDispatch _ = const (return ()) - -- | Forward every node event to the block store and the store publisher, forever. nodeForwarder :: - (MonadIO m) => BlockStore -> Publisher StoreEvent -> Inbox NodeEvent -> - m () + IO () nodeForwarder b pub sub = loopForever $ receive sub >>= atomically . storeDispatch b pub 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,3077 +1,3567 @@ {-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ImportQualifiedPost #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedRecordDot #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE NoFieldSelectors #-} -{-# OPTIONS_GHC -Wno-deprecations #-} - --- | --- Module : Haskoin.Store.Web --- Copyright : (c) Haskoin Developers --- License : MIT --- Maintainer : jprupp@protonmail.ch --- Stability : experimental --- Portability : POSIX --- --- REST API server of Haskoin Store, built with Scotty. --- --- 'runWeb' serves the endpoints described in "Haskoin.Store.WebCommon" and a --- set of endpoints compatible with the Blockchain.info API under --- @\/blockchain\/@. Responses are JSON by default, pretty-printed with --- @?pretty=true@, or binary if the request has the header --- @Accept: application\/octet-stream@. New blocks and mempool transactions are --- streamed at @\/events@, as lines of JSON or over a WebSocket. --- --- Limits on the size of responses are set with 'WebLimits'. Errors are --- returned as JSON with an HTTP status that depends on the 'Except'. --- = Design of the API --- --- * __Two encodings of the same data.__ JSON is easy to use from anywhere. The --- binary encoding is several times smaller and faster to produce and parse, and --- is what the Haskell client uses. --- --- * __Limits protect the server.__ A single request for every transaction of a --- busy address could take minutes and gigabytes. 'WebLimits' caps list sizes --- and offsets, and lower caps apply to full transactions, which are much larger --- than references. --- --- * __Health is measured, not assumed.__ The store reports itself unhealthy when --- it lags behind the network, stops receiving blocks or transactions, has too --- few peers or a backlog of transactions. Load balancers can route around an --- instance that is still syncing or has lost its peers. --- --- * __Slow event clients are dropped.__ Each @\/events@ client gets a bounded --- queue. A client that falls too far behind is disconnected rather than allowed --- to make the server buffer events without limit. --- --- * __Compatibility endpoints ease migration.__ The @\/blockchain\/@ endpoints --- follow the Blockchain.info API so that existing wallets can switch to a --- self-hosted server with few changes. -module Haskoin.Store.Web - ( -- * Web - WebConfig (..), - Except (..), - WebLimits (..), - runWeb, - - -- * Request parsing - decodeTxBody, - ) -where - -import Conduit - ( ConduitT, - await, - concatMapC, - concatMapMC, - dropC, - dropWhileC, - headC, - mapC, - runConduit, - sinkList, - takeC, - takeWhileC, - yield, - (.|), - ) -import Control.Applicative ((<|>)) -import Control.Lens ((.~), (^.)) -import Control.Monad - ( forM_, - unless, - void, - when, - (<=<), - ) -import Control.Monad.Reader - ( MonadReader, - ReaderT, - asks, - local, - runReaderT, - ) -import Control.Monad.Trans (lift) -import Control.Monad.Trans.Class (MonadTrans) -import Control.Monad.Trans.Control - ( liftWith, - restoreT, - ) -import Control.Monad.Trans.Maybe - ( MaybeT (..), - runMaybeT, - ) -import Data.Aeson - ( Encoding, - ToJSON (..), - Value, - ) -import Data.Aeson qualified as A -import Data.Aeson.Encode.Pretty - ( Config (..), - defConfig, - encodePretty', - ) -import Data.Aeson.Encoding - ( encodingToLazyByteString, - list, - ) -import Data.ByteString.Base16 (decodeBase16, parseBase16) -import Data.ByteString.Builder (lazyByteString) -import Data.ByteString.Char8 qualified as C -import Data.ByteString.Lazy qualified as L -import Data.Bytes.Get -import Data.Bytes.Put -import Data.Bytes.Serial -import Data.Char (isSpace) -import Data.Default (Default (..)) -import Data.Function ((&)) -import Data.HashMap.Strict (HashMap) -import Data.HashMap.Strict qualified as HashMap -import Data.HashSet (HashSet) -import Data.HashSet qualified as HashSet -import Data.Int (Int64) -import Data.List (nub) -import Data.Maybe - ( catMaybes, - fromJust, - fromMaybe, - isJust, - mapMaybe, - maybeToList, - ) -import Data.Proxy (Proxy (..)) -import Data.Serialize (decode) -import Data.String (fromString) -import Data.String.Conversions (cs) -import Data.Text (Text) -import Data.Text qualified as T -import Data.Text.Encoding qualified as T -import Data.Text.Lazy qualified as TL -import Data.Time.Clock.POSIX (getPOSIXTime) -import Data.Word (Word32, Word64) -import Database.RocksDB - ( Property (..), - getProperty, - ) -import Haskoin.Address -import Haskoin.Block qualified as H -import Haskoin.Crypto.Keys -import Haskoin.Network -import Haskoin.Node - ( Chain, - Logger, - OnlinePeer (..), - PeerMgr, - chainGetAncestor, - chainGetBest, - getPeers, - logDebug, - logError, - sendMessage, - withSource, - ) -import Haskoin.Script -import Haskoin.Store.BlockStore -import Haskoin.Store.Cache -import Haskoin.Store.Common -import Haskoin.Store.Data -import Haskoin.Store.Database.Reader -import Haskoin.Store.Manager -import Haskoin.Store.WebCommon -import Haskoin.Transaction -import Haskoin.Util -import NQE - ( Publisher, - mailboxFullSTM, - newBoundedInbox, - receiveSTM, - sendSTM, - subscribe, - unsubscribe, - ) -import Network.HTTP.Types - ( Status (..), - status400, - status404, - status409, - status413, - status500, - status503, - statusIsClientError, - statusIsServerError, - statusIsSuccessful, - ) -import Network.Wai - ( Middleware, - Request (..), - responseStatus, - ) -import Network.Wai.Handler.Warp - ( defaultSettings, - setHost, - setPort, - ) -import Network.Wai.Handler.WebSockets (websocketsOr) -import Network.WebSockets - ( acceptRequest, - defaultConnectionOptions, - pendingRequest, - rejectRequestWith, - requestPath, - sendTextData, - ) -import Network.WebSockets qualified as WebSockets -import Network.WebSockets.Connection.PingPong - ( PingPongOptions (..), - defaultPingPongOptions, - withPingPong, - ) -import Network.Wreq qualified as Wreq -import Network.Wreq.Session as Wreq (Session) -import Network.Wreq.Session qualified as Wreq.Session -import Numeric.Natural (Natural) -import System.Metrics.StatsD -import UnliftIO - ( MonadIO, - MonadUnliftIO, - TVar, - askRunInIO, - async, - atomically, - bracket, - bracket_, - checkSTM, - handleAny, - liftIO, - newTVarIO, - orElse, - race_, - readTVar, - readTVarIO, - withAsync, - writeTVar, - ) -import UnliftIO.Concurrent (threadDelay) -import Web.Scotty.Trans qualified as S - --- | Scotty application with access to the web state. -type ScottyT m = S.ScottyT (ReaderT WebState m) - --- | Scotty request handler with access to the web state. -type ActionT m = S.ActionT (ReaderT WebState m) - --- | Limits of the API. A value of @0@ means no limit. -data WebLimits = WebLimits - { -- | maximum number of items in a list response - maxItemCount :: !Word32, - -- | maximum number of full transactions in a list response - maxFullItemCount :: !Word32, - -- | maximum offset of a paged query - maxOffset :: !Word32, - -- | number of items in a list response when no limit is given - defItemCount :: !Word32, - -- | consecutive unused addresses after which xpub derivation stops - xpubGap :: !Word32, - -- | unused addresses to look at for an xpub with no transactions - xpubGapInit :: !Word32, - -- | seconds without a new transaction before the store is reported - -- unhealthy - txTimeout :: !Word64, - -- | seconds without a new block before the store is reported unhealthy - blockTimeout :: !Word64 - } - deriving (Eq, Show) - --- | 200000 items, 5000 full transactions, offset up to 50000, 100 items by --- default, xpub gaps of 32 and 20, transaction timeout of 30 minutes and --- block timeout of four hours. -instance Default WebLimits where - def = - WebLimits - { maxItemCount = 200000, - maxFullItemCount = 5000, - maxOffset = 50000, - defItemCount = 100, - xpubGap = 32, - xpubGapInit = 20, - txTimeout = 3600 `div` 2, - blockTimeout = 4 * 3600 - } - --- | Configuration of the web server. -data WebConfig = WebConfig - { -- | address to listen on, such as @*@ for all - host :: !String, - -- | port to listen on - port :: !Int, - -- | running store to serve - store :: !Store, - -- | blocks that the database may lag behind the headers before the store - -- is reported unhealthy - maxLaggingBlocks :: !Int, - -- | transactions that may be waiting to be imported before the store is - -- reported unhealthy - maxPendingTxs :: !Int, - -- | fewest peers before the store is reported unhealthy - minPeers :: !Int, - -- | limits of the API - limits :: !WebLimits, - -- | version reported by the health check - version :: !String, - -- | the mempool is not indexed, so do not report it in health checks - noMempool :: !Bool, - -- | StatsD client, if metrics are enabled - stats :: !(Maybe Stats), - -- | microseconds between updates of the price ticker - tickerRefresh :: !Int, - -- | URL of the price ticker service - tickerURL :: !String, - -- | URL of the historical price service - priceHistoryURL :: !String, - -- | disable the xpub endpoints - noXPub :: !Bool, - -- | disable the Blockchain.info compatible endpoints - noBlockchainInfo :: !Bool, - -- | seconds between health checks - healthCheckInterval :: !Int, - -- | log messages here - logger :: !Logger - } - --- | State shared by all request handlers. -data WebState = WebState - { -- | configuration - config :: !WebConfig, - -- | latest prices by currency code - ticker :: !(TVar (HashMap Text BinfoTicker)), - -- | StatsD metrics, if enabled - metrics :: !(Maybe WebMetrics), - -- | HTTP session for price requests - session :: !Wreq.Session, - -- | result of the latest health check - health :: !(TVar HealthCheck) - } - --- | StatsD metrics of the web server: a timing for each kind of request, --- under @web.\@, error counters and a gauge of connected event --- clients. -data WebMetrics = WebMetrics - { -- Addresses - addressTx :: !StatTiming, - addressTxFull :: !StatTiming, - addressBalance :: !StatTiming, - addressUnspent :: !StatTiming, - xpub :: !StatTiming, - xpubDelete :: !StatTiming, - xpubTxFull :: !StatTiming, - xpubTx :: !StatTiming, - xpubBalance :: !StatTiming, - xpubUnspent :: !StatTiming, - -- Transactions - tx :: !StatTiming, - txRaw :: !StatTiming, - txAfter :: !StatTiming, - txBlock :: !StatTiming, - txBlockRaw :: !StatTiming, - txPost :: !StatTiming, - mempool :: !StatTiming, - -- Blocks - block :: !StatTiming, - blockRaw :: !StatTiming, - -- Blockchain - binfoMultiaddr :: !StatTiming, - binfoBalance :: !StatTiming, - binfoAddressRaw :: !StatTiming, - binfoUnspent :: !StatTiming, - binfoTxRaw :: !StatTiming, - binfoBlock :: !StatTiming, - binfoBlockHeight :: !StatTiming, - binfoBlockLatest :: !StatTiming, - binfoBlockRaw :: !StatTiming, - binfoMempool :: !StatTiming, - binfoExportHistory :: !StatTiming, - -- Blockchain /q endpoints - binfoQaddresstohash :: !StatTiming, - binfoQhashtoaddress :: !StatTiming, - binfoQaddrpubkey :: !StatTiming, - binfoQpubkeyaddr :: !StatTiming, - binfoQhashpubkey :: !StatTiming, - binfoQgetblockcount :: !StatTiming, - binfoQlatesthash :: !StatTiming, - binfoQbcperblock :: !StatTiming, - binfoQtxtotalbtcoutput :: !StatTiming, - binfoQtxtotalbtcinput :: !StatTiming, - binfoQtxfee :: !StatTiming, - binfoQtxresult :: !StatTiming, - binfoQgetreceivedbyaddress :: !StatTiming, - binfoQgetsentbyaddress :: !StatTiming, - binfoQaddressbalance :: !StatTiming, - binfoQaddressfirstseen :: !StatTiming, - -- Errors - serverErrors :: StatCounter, - clientErrors :: StatCounter, - -- Others - health :: !StatTiming, - peers :: !StatTiming, - db :: !StatTiming, - events :: !StatGauge - } - --- | Register the web server metrics with a StatsD client. -createMetrics :: (MonadIO m) => Stats -> m WebMetrics -createMetrics s = liftIO $ do - -- Addresses - addressTx <- d "address_transactions" - addressTxFull <- d "address_transactions_full" - addressBalance <- d "address_balance" - addressUnspent <- d "address_unspent" - xpub <- d "xpub" - xpubDelete <- d "xpub_delete" - xpubTxFull <- d "xpub_transactions_full" - xpubTx <- d "xpub_transactions" - xpubBalance <- d "xpub_balances" - xpubUnspent <- d "xpub_unspent" - - -- Transactions - tx <- d "transaction" - txRaw <- d "transaction_raw" - txAfter <- d "transaction_after" - txPost <- d "transaction_post" - txBlock <- d "transactions_block" - txBlockRaw <- d "transactions_block_raw" - mempool <- d "mempool" - - -- Blocks - block <- d "block" - blockRaw <- d "block_raw" - - -- Blockchain - binfoMultiaddr <- d "blockchain_multiaddr" - binfoBalance <- d "blockchain_balance" - binfoAddressRaw <- d "blockchain_rawaddr" - binfoUnspent <- d "blockchain_unspent" - binfoTxRaw <- d "blockchain_rawtx" - binfoBlock <- d "blockchain_blocks" - binfoBlockHeight <- d "blockchain_block_height" - binfoBlockLatest <- d "blockchain_latestblock" - binfoBlockRaw <- d "blockchain_rawblock" - binfoMempool <- d "blockchain_mempool" - binfoExportHistory <- d "blockchain_export_history" - - -- Blockchain /q endpoints - binfoQaddresstohash <- d "blockchain_q_addresstohash" - binfoQhashtoaddress <- d "blockchain_q_hashtoaddress" - binfoQaddrpubkey <- d "blockckhain_q_addrpubkey" - binfoQpubkeyaddr <- d "blockchain_q_pubkeyaddr" - binfoQhashpubkey <- d "blockchain_q_hashpubkey" - binfoQgetblockcount <- d "blockchain_q_getblockcount" - binfoQlatesthash <- d "blockchain_q_latesthash" - binfoQbcperblock <- d "blockchain_q_bcperblock" - binfoQtxtotalbtcoutput <- d "blockchain_q_txtotalbtcoutput" - binfoQtxtotalbtcinput <- d "blockchain_q_txtotalbtcinput" - binfoQtxfee <- d "blockchain_q_txfee" - binfoQtxresult <- d "blockchain_q_txresult" - binfoQgetreceivedbyaddress <- d "blockchain_q_getreceivedbyaddress" - binfoQgetsentbyaddress <- d "blockchain_q_getsentbyaddress" - binfoQaddressbalance <- d "blockchain_q_addressbalance" - binfoQaddressfirstseen <- d "blockchain_q_addressfirstseen" - - -- Errors - serverErrors <- c "server_errors" - clientErrors <- c "client_errors" - - -- Others - health <- d "health" - peers <- d "peers" - db <- d "dbstats" - - events <- g "events_connected" - return WebMetrics {..} - where - d x = newStatTiming s ("web." <> x) 10 - g x = newStatGauge s ("web." <> x) 0 - c x = newStatCounter s ("web." <> x) 10 - --- | Increase a gauge while an action runs. -withGaugeIO :: (MonadUnliftIO m) => StatGauge -> m a -> m a -withGaugeIO g = bracket_ (incrementGauge g 1) (decrementGauge g 1) - --- | Increase a gauge of the web metrics while a handler runs. -withGaugeIncrease :: - (MonadUnliftIO m) => - (WebMetrics -> StatGauge) -> - ActionT m a -> - ActionT m a -withGaugeIncrease gf go = - askl (.metrics) >>= \case - Nothing -> go - Just m -> do - s <- liftWith $ \run -> withGaugeIO (gf m) (run go) - restoreT $ return s - --- | Record how long a handler takes in a timing of the web metrics. -withMetrics :: - (MonadUnliftIO m) => (WebMetrics -> StatTiming) -> ActionT m a -> ActionT m a -withMetrics df go = - askl (.metrics) >>= \case - Nothing -> go - Just m -> - restoreT . return - =<< liftWith (\run -> bracket time (stop m) (const (run go))) - where - time = round . (* 1000) <$> liftIO getPOSIXTime - stop m t1 = do - t2 <- time - let ms = t2 - t1 - liftIO $ addTiming (df m) ms - --- | Encoding of a response. -data SerialAs - = -- | binary, for @Accept: application\/octet-stream@ - SerialAsBinary - | -- | compact JSON - SerialAsJSON - | -- | indented JSON, for @?pretty=true@ - SerialAsPrettyJSON - deriving (Eq, Show) - -instance - (MonadUnliftIO m) => - StoreReadBase (ReaderT WebState m) - where - getCtx = runInWebReader getCtx - getNetwork = runInWebReader getNetwork - getBestBlock = runInWebReader getBestBlock - getBlocksAtHeight height = runInWebReader (getBlocksAtHeight height) - getBlock bh = runInWebReader (getBlock bh) - getTxData th = runInWebReader (getTxData th) - getManyTxData ths = runInWebReader (getManyTxData ths) - getSpender op = runInWebReader (getSpender op) - getUnspent op = runInWebReader (getUnspent op) - getBalance a = runInWebReader (getBalance a) - getMempool = runInWebReader getMempool - getMempoolPage = runInWebReader . getMempoolPage - -instance - (MonadUnliftIO m) => - StoreReadExtra (ReaderT WebState m) - where - getMaxGap = runInWebReader getMaxGap - getInitialGap = runInWebReader getInitialGap - getBalances as = runInWebReader (getBalances as) - getAddressesTxs as = runInWebReader . getAddressesTxs as - getAddressTxs a = runInWebReader . getAddressTxs a - getAddressUnspents a = runInWebReader . getAddressUnspents a - getAddressesUnspents as = runInWebReader . getAddressesUnspents as - xPubBals = runInWebReader . xPubBals - xPubUnspents xpub xbals = runInWebReader . xPubUnspents xpub xbals - xPubTxs xpub xbals = runInWebReader . xPubTxs xpub xbals - xPubTxCount xpub = runInWebReader . xPubTxCount xpub - getNumTxData = runInWebReader . getNumTxData - -instance (MonadUnliftIO m) => StoreReadBase (ActionT m) where - getCtx = lift getCtx - getNetwork = lift getNetwork - getBestBlock = lift getBestBlock - getBlocksAtHeight = lift . getBlocksAtHeight - getBlock = lift . getBlock - getTxData = lift . getTxData - getManyTxData = lift . getManyTxData - getSpender = lift . getSpender - getUnspent = lift . getUnspent - getBalance = lift . getBalance - getMempool = lift getMempool - getMempoolPage = lift . getMempoolPage - -instance (MonadUnliftIO m) => StoreReadExtra (ActionT m) where - getBalances = lift . getBalances - getAddressesTxs as = lift . getAddressesTxs as - getAddressTxs a = lift . getAddressTxs a - getAddressUnspents a = lift . getAddressUnspents a - getAddressesUnspents as = lift . getAddressesUnspents as - xPubBals = lift . xPubBals - xPubUnspents xpub xbals = lift . xPubUnspents xpub xbals - xPubTxs xpub xbals = lift . xPubTxs xpub xbals - xPubTxCount xpub = lift . xPubTxCount xpub - getMaxGap = lift getMaxGap - getInitialGap = lift getInitialGap - getNumTxData = lift . getNumTxData - -------------------- --- Path Handlers -- -------------------- - --- | Run the web server forever. Also starts a thread that updates prices, unless --- the Blockchain.info endpoints are disabled, and a thread that runs health --- checks. -runWeb :: (MonadUnliftIO m) => WebConfig -> m () -runWeb config = do - ticker <- newTVarIO HashMap.empty - metrics <- mapM createMetrics config.stats - session <- liftIO Wreq.Session.newAPISession - health <- runHealthCheck >>= newTVarIO - let state = WebState {..} - withAsync (priceUpdater session ticker) $ \_a1 -> - withAsync (healthCheckLoop health) $ \_a2 -> do - runner <- askRunInIO - S.scottyOptsT opts (runner . flip runReaderT state) $ do - S.middleware $ webSocketEvents state - S.middleware (logIt config.logger) - handlePaths config - S.notFound $ raise ThingNotFound - where - priceUpdater session = - unless config.noBlockchainInfo - . price - (withSource "Price" config.logger) - config.store.net - session - config.tickerURL - config.tickerRefresh - runHealthCheck = runReaderT (healthCheck config) config.store.db - healthCheckLoop v = loopForever $ do - threadDelay (config.healthCheckInterval * 1000 * 1000) - runHealthCheck >>= atomically . writeTVar v - opts = S.defaultOptions {S.settings = settings defaultSettings} - settings = setPort config.port . setHost (fromString config.host) - --- | Historical prices of the coin of the network in a currency at several times. Returns an empty list on failure. -getRates :: - (MonadUnliftIO m) => - Logger -> - Network -> - Wreq.Session -> - String -> - Text -> - [Word64] -> - m [BinfoRate] -getRates logger net session url currency times = do - handleAny err $ do - r <- - liftIO $ - Wreq.asJSON - =<< Wreq.Session.postWith opts session url body - return $ r ^. Wreq.responseBody - where - err _ = do - logError logger "Could not get historic prices" - return [] - body = toJSON times - base = - Wreq.defaults - & Wreq.param "base" .~ [T.toUpper $ T.pack net.name] - opts = base & Wreq.param "quote" .~ [currency] - --- | Update the prices of the coin of the network periodically, for BTC and BCH only. -price :: - (MonadUnliftIO m) => - Logger -> - Network -> - Wreq.Session -> - String -> - Int -> - TVar (HashMap Text BinfoTicker) -> - m () -price logger net session url pget v = forM_ purl $ \u -> loopForever $ do - let err e = logError logger $ cs (show e) - handleAny err $ do - r <- liftIO $ Wreq.asJSON =<< Wreq.Session.get session u - atomically . writeTVar v $ r ^. Wreq.responseBody - threadDelay pget - where - purl = case code of - Nothing -> Nothing - Just x -> Just (url <> "?base=" <> x) - where - code - | net == btc = Just "btc" - | net == bch = Just "bch" - | otherwise = Nothing - --- | Respond with an error and stop handling the request. -raise :: (MonadIO m) => Except -> ActionT m a -raise e = do - askl (.metrics) >>= mapM_ \m -> do - liftIO $ - mapM_ (`incrementCounter` 1) $ - if - | statusIsClientError (errStatus e) -> Just m.clientErrors - | statusIsServerError (errStatus e) -> Just m.serverErrors - | otherwise -> Nothing - setHeaders - S.status $ errStatus e - S.json e - S.finish - --- | HTTP status of an error. -errStatus :: Except -> Status -errStatus ThingNotFound = status404 -errStatus BadRequest = status400 -errStatus UserError {} = status400 -errStatus StringError {} = status400 -errStatus ServerError = status500 -errStatus TxIndexConflict {} = status409 -errStatus ServerTimeout = status500 -errStatus RequestTooLarge = status413 - --- | Register the handlers of every endpoint, except those disabled in the configuration. -handlePaths :: - (MonadUnliftIO m) => - WebConfig -> - S.ScottyT (ReaderT WebState m) () -handlePaths cfg = do - -- Block Paths - pathCompact - (GetBlockBest <$> paramDef) - scottyBlockBest - (marshalEncoding net) - (marshalValue net) - pathCompact - (GetBlockHeight <$> paramCapture <*> paramDef) - (fmap SerialList . scottyBlockHeight) - (list (marshalEncoding net) . (.get)) - (json_list (marshalValue net) . (.get)) - pathCompact - (GetBlockTime <$> paramCapture <*> paramDef) - scottyBlockTime - (marshalEncoding net) - (marshalValue net) - pathCompact - (GetBlockMTP <$> paramCapture <*> paramDef) - scottyBlockMTP - (marshalEncoding net) - (marshalValue net) - pathCompact - (GetBlock <$> paramCapture <*> paramDef) - scottyBlock - (marshalEncoding net) - (marshalValue net) - pathCompact - (GetTx <$> paramCapture) - scottyTx - (marshalEncoding net) - (marshalValue net) - pathCompact - (GetTxRaw <$> paramCapture) - scottyTxRaw - toEncoding - toJSON - pathCompact - (PostTx <$> parseTxBody) - scottyPostTx - toEncoding - toJSON - pathCompact - (GetAddrTxs <$> paramCapture <*> parseLimits) - (fmap SerialList . scottyAddrTxs) - toEncoding - toJSON - pathCompact - (GetAddrBalance <$> paramCapture) - scottyAddrBalance - (marshalEncoding net) - (marshalValue net) - pathCompact - (GetAddrUnspent <$> paramCapture <*> parseLimits) - (fmap SerialList . scottyAddrUnspent) - (list (marshalEncoding net) . (.get)) - (json_list (marshalValue net) . (.get)) - pathCompact - (GetPeers & return) - (fmap SerialList . scottyPeers) - toEncoding - toJSON - pathCompact - (GetHealth & return) - scottyHealth - toEncoding - toJSON - pathCompact - (GetMempool <$> paramOptional <*> parseOffset) - (fmap SerialList . scottyMempool) - toEncoding - toJSON - pathCompact - (GetBlocks <$> paramRequired <*> paramDef) - (fmap SerialList . scottyBlocks) - (list (marshalEncoding net) . (.get)) - (json_list (marshalValue net) . (.get)) - pathCompact - (GetBlockRaw <$> paramCapture) - scottyBlockRaw - toEncoding - toJSON - pathCompact - (GetBlockBestRaw & return) - scottyBlockBestRaw - toEncoding - toJSON - pathCompact - (GetBlockLatest <$> paramDef) - (fmap SerialList . scottyBlockLatest) - (list (marshalEncoding net) . (.get)) - (json_list (marshalValue net) . (.get)) - pathCompact - (GetBlockHeights <$> paramRequired <*> paramDef) - (fmap SerialList . scottyBlockHeights) - (list (marshalEncoding net) . (.get)) - (json_list (marshalValue net) . (.get)) - pathCompact - (GetBlockHeightRaw <$> paramCapture) - scottyBlockHeightRaw - toEncoding - toJSON - pathCompact - (GetBlockTimeRaw <$> paramCapture) - scottyBlockTimeRaw - toEncoding - toJSON - pathCompact - (GetBlockMTPRaw <$> paramCapture) - scottyBlockMTPRaw - toEncoding - toJSON - pathCompact - (GetTxs <$> paramRequired) - (fmap SerialList . scottyTxs) - (list (marshalEncoding net) . (.get)) - (json_list (marshalValue net) . (.get)) - pathCompact - (GetTxsRaw <$> paramRequired) - scottyTxsRaw - toEncoding - toJSON - pathCompact - (GetTxsBlock <$> paramCapture) - (fmap SerialList . scottyTxsBlock) - (list (marshalEncoding net) . (.get)) - (json_list (marshalValue net) . (.get)) - pathCompact - (GetTxsBlockRaw <$> paramCapture) - scottyTxsBlockRaw - toEncoding - toJSON - pathCompact - (GetTxAfter <$> paramCapture <*> paramCapture) - scottyTxAfter - toEncoding - toJSON - pathCompact - (GetAddrsTxs <$> paramRequired <*> parseLimits) - (fmap SerialList . scottyAddrsTxs) - toEncoding - toJSON - pathCompact - (GetAddrTxsFull <$> paramCapture <*> parseLimits) - (fmap SerialList . scottyAddrTxsFull) - (list (marshalEncoding net) . (.get)) - (json_list (marshalValue net) . (.get)) - pathCompact - (GetAddrsTxsFull <$> paramRequired <*> parseLimits) - (fmap SerialList . scottyAddrsTxsFull) - (list (marshalEncoding net) . (.get)) - (json_list (marshalValue net) . (.get)) - pathCompact - (GetAddrsBalance <$> paramRequired) - (fmap SerialList . scottyAddrsBalance) - (list (marshalEncoding net) . (.get)) - (json_list (marshalValue net) . (.get)) - pathCompact - (GetAddrsUnspent <$> paramRequired <*> parseLimits) - (fmap SerialList . scottyAddrsUnspent) - (list (marshalEncoding net) . (.get)) - (json_list (marshalValue net) . (.get)) - S.get "/events" scottyEvents - S.get "/dbstats" scottyDbStats - unless cfg.noXPub $ do - pathCompact - (GetXPub <$> paramCapture <*> paramDef <*> paramDef) - scottyXPub - toEncoding - toJSON - pathCompact - (GetXPubTxs <$> paramCapture <*> paramDef <*> parseLimits <*> paramDef) - (fmap SerialList . scottyXPubTxs) - toEncoding - toJSON - pathCompact - (GetXPubTxsFull <$> paramCapture <*> paramDef <*> parseLimits <*> paramDef) - (fmap SerialList . scottyXPubTxsFull) - (list (marshalEncoding net) . (.get)) - (json_list (marshalValue net) . (.get)) - pathCompact - (GetXPubBalances <$> paramCapture <*> paramDef <*> paramDef) - (fmap SerialList . scottyXPubBalances) - (list (marshalEncoding net) . (.get)) - (json_list (marshalValue net) . (.get)) - pathCompact - (GetXPubUnspent <$> paramCapture <*> paramDef <*> parseLimits <*> paramDef) - (fmap SerialList . scottyXPubUnspent) - (list (marshalEncoding net) . (.get)) - (json_list (marshalValue net) . (.get)) - pathCompact - (DelCachedXPub <$> paramCapture <*> paramDef) - scottyDelXPub - toEncoding - toJSON - unless cfg.noBlockchainInfo $ do - S.post "/blockchain/multiaddr" scottyMultiAddr - S.get "/blockchain/multiaddr" scottyMultiAddr - S.get "/blockchain/balance" scottyShortBal - S.post "/blockchain/balance" scottyShortBal - S.get "/blockchain/rawaddr/:addr" scottyRawAddr - S.get "/blockchain/address/:addr" scottyRawAddr - S.get "/blockchain/xpub/:addr" scottyRawAddr - S.post "/blockchain/unspent" scottyBinfoUnspent - S.get "/blockchain/unspent" scottyBinfoUnspent - S.get "/blockchain/rawtx/:txid" scottyBinfoTx - S.get "/blockchain/rawblock/:block" scottyBinfoBlock - S.get "/blockchain/latestblock" scottyBinfoLatest - S.get "/blockchain/unconfirmed-transactions" scottyBinfoMempool - S.get "/blockchain/block-height/:height" scottyBinfoBlockHeight - S.get "/blockchain/blocks/:milliseconds" scottyBinfoBlocksDay - S.get "/blockchain/export-history" scottyBinfoHistory - S.post "/blockchain/export-history" scottyBinfoHistory - S.get "/blockchain/q/addresstohash/:addr" scottyBinfoAddrToHash - S.get "/blockchain/q/hashtoaddress/:hash" scottyBinfoHashToAddr - S.get "/blockchain/q/addrpubkey/:pubkey" scottyBinfoAddrPubkey - S.get "/blockchain/q/pubkeyaddr/:addr" scottyBinfoPubKeyAddr - S.get "/blockchain/q/hashpubkey/:pubkey" scottyBinfoHashPubkey - S.get "/blockchain/q/getblockcount" scottyBinfoGetBlockCount - S.get "/blockchain/q/latesthash" scottyBinfoLatestHash - S.get "/blockchain/q/bcperblock" scottyBinfoSubsidy - S.get "/blockchain/q/txtotalbtcoutput/:txid" scottyBinfoTotalOut - S.get "/blockchain/q/txtotalbtcinput/:txid" scottyBinfoTotalInput - S.get "/blockchain/q/txfee/:txid" scottyBinfoTxFees - S.get "/blockchain/q/txresult/:txid/:addr" scottyBinfoTxResult - S.get "/blockchain/q/getreceivedbyaddress/:addr" scottyBinfoReceived - S.get "/blockchain/q/getsentbyaddress/:addr" scottyBinfoSent - S.get "/blockchain/q/addressbalance/:addr" scottyBinfoAddrBalance - S.get "/blockchain/q/addressfirstseen/:addr" scottyFirstSeen - where - json_list f = toJSONList . map f - net = cfg.store.net - --- | Register a handler for an API resource, with compact JSON by default. -pathCompact :: - (ApiResource a b, MonadUnliftIO m) => - ActionT m a -> - (a -> ActionT m b) -> - (b -> Encoding) -> - (b -> Value) -> - S.ScottyT (ReaderT WebState m) () -pathCompact parser action encJson encValue = - pathCommon parser action encJson encValue False - --- | Register a handler for an API resource: parse the request, run the handler, --- and encode the response as JSON or binary, as the client asked. -pathCommon :: - (ApiResource a b, MonadUnliftIO m) => - ActionT m a -> - (a -> ActionT m b) -> - (b -> Encoding) -> - (b -> Value) -> - Bool -> - ScottyT m () -pathCommon parser action encJson encValue pretty = - S.addroute (resourceMethod proxy) (capturePath proxy) $ do - setHeaders - proto <- setupContentType pretty - apiRes <- parser - res <- action apiRes - S.raw $ protoSerial proto encJson encValue res - where - toProxy :: ActionT m a -> Proxy a - toProxy = const Proxy - proxy = toProxy parser - --- | Respond with JSON. -streamEncoding :: (MonadIO m) => Encoding -> ActionT m () -streamEncoding e = do - S.setHeader "Content-Type" "application/json; charset=utf-8" - S.raw (encodingToLazyByteString e) - --- | Encode a response in binary, JSON or pretty JSON. -protoSerial :: - (Serial a) => - SerialAs -> - (a -> Encoding) -> - (a -> Value) -> - a -> - L.ByteString -protoSerial SerialAsBinary _ _ = runPutL . serialize -protoSerial SerialAsJSON f _ = encodingToLazyByteString . f -protoSerial SerialAsPrettyJSON _ g = - encodePretty' defConfig {confTrailingNewline = True} . g - --- | Allow requests from any origin. -setHeaders :: (MonadIO m) => S.ActionT m () -setHeaders = S.setHeader "Access-Control-Allow-Origin" "*" - --- | Respond with JSON, pretty if the @pretty@ parameter or the default says so. -setupJSON :: (MonadUnliftIO m) => Bool -> S.ActionT m SerialAs -setupJSON pretty = do - S.setHeader "Content-Type" "application/json" - p <- param "pretty" `rescue` return pretty - return $ if p then SerialAsPrettyJSON else SerialAsJSON - --- | Respond with binary. -setupBinary :: (MonadIO m) => S.ActionT m SerialAs -setupBinary = do - S.setHeader "Content-Type" "application/octet-stream" - return SerialAsBinary - --- | Choose the encoding of the response from the @Accept@ header of the request. -setupContentType :: (MonadUnliftIO m) => Bool -> S.ActionT m SerialAs -setupContentType pretty = do - accept <- S.header "accept" - maybe (setupJSON pretty) setType accept - where - setType "application/octet-stream" = setupBinary - setType _ = setupJSON pretty - --- GET Block / GET Blocks -- - --- | Handler for @GET \/block\/:block@: a block by hash. -scottyBlock :: - (MonadUnliftIO m) => GetBlock -> ActionT m BlockData -scottyBlock (GetBlock h (NoTx noTx)) = withMetrics (.block) $ do - getBlock h >>= \case - Nothing -> - raise ThingNotFound - Just b -> do - return $ pruneTx noTx b - --- | Blocks by hash, without duplicates, leaving out unknown ones. -getBlocks :: - (MonadUnliftIO m) => - [H.BlockHash] -> - Bool -> - ActionT m [BlockData] -getBlocks hs notx = - (pruneTx notx <$>) . catMaybes <$> mapM getBlock (nub hs) - --- | Handler for @GET \/blocks?blocks=…@: several blocks by hash. -scottyBlocks :: - (MonadUnliftIO m) => GetBlocks -> ActionT m [BlockData] -scottyBlocks (GetBlocks hs (NoTx notx)) = - withMetrics (.block) $ - getBlocks hs notx - --- | Keep only the coinbase in the list of transactions of a block, if the flag is 'True'. -pruneTx :: Bool -> BlockData -> BlockData -pruneTx False b = b -pruneTx True BlockData {..} = BlockData {txs = take 1 txs, ..} - --- GET BlockRaw -- - --- | Handler for @GET \/block\/:block\/raw@: a block by hash, serialized as in the peer-to-peer protocol. -scottyBlockRaw :: - (MonadUnliftIO m) => - GetBlockRaw -> - ActionT m (RawResult H.Block) -scottyBlockRaw (GetBlockRaw h) = - withMetrics (.blockRaw) $ - RawResult <$> getRawBlock h - --- | Block by hash with all its transactions. Responds with an error if not found. -getRawBlock :: - (MonadUnliftIO m) => - H.BlockHash -> - ActionT m H.Block -getRawBlock h = - getBlock h >>= maybe (raise ThingNotFound) return >>= lift . toRawBlock - --- | Rebuild a block from its data and its transactions. -toRawBlock :: (StoreReadBase m) => BlockData -> m H.Block -toRawBlock b = do - txs <- map transactionData . catMaybes <$> getTransactions b.txs - return H.Block {header = b.header, txs} - --- GET BlockBest / BlockBestRaw -- - --- | Handler for @GET \/block\/best@: the best block. -scottyBlockBest :: - (MonadUnliftIO m) => GetBlockBest -> ActionT m BlockData -scottyBlockBest (GetBlockBest (NoTx notx)) = - withMetrics (.block) $ - maybe (raise ThingNotFound) (return . pruneTx notx) <=< runMaybeT $ - MaybeT getBestBlock >>= MaybeT . getBlock - --- | Handler for @GET \/block\/best\/raw@: the best block, serialized. -scottyBlockBestRaw :: - (MonadUnliftIO m) => - GetBlockBestRaw -> - ActionT m (RawResult H.Block) -scottyBlockBestRaw _ = - withMetrics (.blockRaw) $ - maybe (raise ThingNotFound) (return . RawResult) <=< runMaybeT $ - MaybeT getBestBlock >>= lift . getRawBlock - --- GET BlockLatest -- - --- | Handler for @GET \/block\/latest@: the best block and its ancestors, up to 100 blocks. -scottyBlockLatest :: - (MonadUnliftIO m) => - GetBlockLatest -> - ActionT m [BlockData] -scottyBlockLatest (GetBlockLatest (NoTx noTx)) = - withMetrics (.block) $ - getBestBlock >>= maybe (raise ThingNotFound) (go [] <=< getBlock) - where - go acc Nothing = return $ reverse acc - go acc (Just b) - | b.height <= 0 = return $ reverse acc - | length acc == 99 = return . reverse $ pruneTx noTx b : acc - | otherwise = go (pruneTx noTx b : acc) =<< getBlock b.header.prev - --- GET BlockHeight / BlockHeights / BlockHeightRaw -- - --- | Handler for @GET \/block\/height\/:height@: the blocks at a height. -scottyBlockHeight :: - (MonadUnliftIO m) => GetBlockHeight -> ActionT m [BlockData] -scottyBlockHeight (GetBlockHeight h (NoTx notx)) = - withMetrics (.block) $ - getBlocksAtHeight (fromIntegral h) - >>= (`getBlocks` notx) - --- | Handler for @GET \/block\/heights?heights=…@: the blocks at several heights. -scottyBlockHeights :: - (MonadUnliftIO m) => - GetBlockHeights -> - ActionT m [BlockData] -scottyBlockHeights (GetBlockHeights (HeightsParam heights) (NoTx notx)) = - withMetrics (.block) $ - mapM (getBlocksAtHeight . fromIntegral) heights - >>= (`getBlocks` notx) . concat - --- | Handler for @GET \/block\/height\/:height\/raw@: the blocks at a height, serialized. -scottyBlockHeightRaw :: - (MonadUnliftIO m) => - GetBlockHeightRaw -> - ActionT m (RawResultList H.Block) -scottyBlockHeightRaw (GetBlockHeightRaw h) = - withMetrics (.blockRaw) $ - fmap RawResultList $ - mapM getRawBlock =<< getBlocksAtHeight (fromIntegral h) - --- GET BlockTime / BlockTimeRaw -- - --- | Handler for @GET \/block\/time\/:time@: the last block with a timestamp at or before a time. -scottyBlockTime :: - (MonadUnliftIO m) => - GetBlockTime -> - ActionT m BlockData -scottyBlockTime (GetBlockTime (TimeParam t) (NoTx notx)) = - withMetrics (.block) $ do - ch <- askl (.config.store.chain) - blockAtOrBefore ch t >>= \case - Nothing -> raise ThingNotFound - Just b -> return $ pruneTx notx b - --- | Handler for @GET \/block\/mtp\/:time@: the first block with a median time past at or after a time. -scottyBlockMTP :: - (MonadUnliftIO m) => - GetBlockMTP -> - ActionT m BlockData -scottyBlockMTP (GetBlockMTP (TimeParam t) (NoTx notx)) = - withMetrics (.block) $ do - ch <- askl (.config.store.chain) - blockAtOrAfterMTP ch t >>= \case - Nothing -> raise ThingNotFound - Just b -> return $ pruneTx notx b - --- | Handler for @GET \/block\/time\/:time\/raw@: the last block with a timestamp at or before a time, serialized. -scottyBlockTimeRaw :: - (MonadUnliftIO m) => - GetBlockTimeRaw -> - ActionT m (RawResult H.Block) -scottyBlockTimeRaw (GetBlockTimeRaw (TimeParam t)) = - withMetrics (.blockRaw) $ do - ch <- askl (.config.store.chain) - blockAtOrBefore ch t >>= \case - Nothing -> raise ThingNotFound - Just b -> RawResult <$> lift (toRawBlock b) - --- | Handler for @GET \/block\/mtp\/:time\/raw@: the first block with a median time past at or after a time, serialized. -scottyBlockMTPRaw :: - (MonadUnliftIO m) => - GetBlockMTPRaw -> - ActionT m (RawResult H.Block) -scottyBlockMTPRaw (GetBlockMTPRaw (TimeParam t)) = - withMetrics (.blockRaw) $ do - ch <- askl (.config.store.chain) - blockAtOrAfterMTP ch t >>= \case - Nothing -> raise ThingNotFound - Just b -> RawResult <$> lift (toRawBlock b) - --- GET Transactions -- - --- | Handler for @GET \/transaction\/:txid@: a transaction. -scottyTx :: (MonadUnliftIO m) => GetTx -> ActionT m Transaction -scottyTx (GetTx txid) = - withMetrics (.tx) $ - getTransaction txid >>= maybe (raise ThingNotFound) return - --- | Handler for @GET \/transactions?txids=…@: several transactions. -scottyTxs :: - (MonadUnliftIO m) => GetTxs -> ActionT m [Transaction] -scottyTxs (GetTxs txids) = - withMetrics (.tx) $ - catMaybes <$> getTransactions (nub txids) - --- | Handler for @GET \/transaction\/:txid\/raw@: a transaction, serialized. -scottyTxRaw :: - (MonadUnliftIO m) => GetTxRaw -> ActionT m (RawResult Tx) -scottyTxRaw (GetTxRaw txid) = - withMetrics (.txRaw) $ - getTransaction txid - >>= \case - Nothing -> raise ThingNotFound - Just tx -> return $ RawResult (transactionData tx) - --- | Handler for @GET \/transactions\/raw?txids=…@: several transactions, serialized. -scottyTxsRaw :: - (MonadUnliftIO m) => - GetTxsRaw -> - ActionT m (RawResultList Tx) -scottyTxsRaw (GetTxsRaw txids) = - withMetrics (.txRaw) $ - RawResultList . map transactionData . catMaybes - <$> getTransactions (nub txids) - --- | Transactions of a block. Responds with an error if not found. -getTxsBlock :: - (MonadUnliftIO m) => - H.BlockHash -> - ActionT m [Transaction] -getTxsBlock h = - getBlock h >>= \case - Nothing -> raise ThingNotFound - Just b -> catMaybes <$> getTransactions b.txs - --- | Handler for @GET \/transactions\/block\/:block@: the transactions of a block. -scottyTxsBlock :: - (MonadUnliftIO m) => - GetTxsBlock -> - ActionT m [Transaction] -scottyTxsBlock (GetTxsBlock h) = - withMetrics (.txBlock) $ getTxsBlock h - --- | Handler for @GET \/transactions\/block\/:block\/raw@: the transactions of a block, serialized. -scottyTxsBlockRaw :: - (MonadUnliftIO m) => - GetTxsBlockRaw -> - ActionT m (RawResultList Tx) -scottyTxsBlockRaw (GetTxsBlockRaw h) = - withMetrics (.txBlockRaw) $ - RawResultList . map transactionData <$> getTxsBlock h - --- GET TransactionAfterHeight -- - --- | Handler for @GET \/transaction\/:txid\/after\/:height@: whether any ancestor of a transaction is a coinbase confirmed after a height. -scottyTxAfter :: - (MonadUnliftIO m) => - GetTxAfter -> - ActionT m (GenericResult (Maybe Bool)) -scottyTxAfter (GetTxAfter txid height) = - withMetrics (.txAfter) $ - GenericResult . fst <$> cbAfterHeight (fromIntegral height) txid - --- | Check if any of the ancestors of this transaction is a coinbase after the --- specified height. Returns 'Nothing' if answer cannot be computed before --- hitting limits. -cbAfterHeight :: - (StoreReadBase m) => - H.BlockHeight -> - TxHash -> - m (Maybe Bool, Int) -cbAfterHeight height txid = - inputs n HashSet.empty HashSet.empty [txid] - where - n = 10000 - inputs 0 _ _ [] = return (Nothing, 10000) - inputs i is ns [] = - let is' = HashSet.union is ns - ns' = HashSet.empty - ts = HashSet.toList (HashSet.difference ns is) - in case ts of - [] -> return (Just False, n - i) - _ -> inputs i is' ns' ts - inputs i is ns (t : ts) = - getTransaction t >>= \case - Nothing -> return (Nothing, n - i) - Just tx - | height_check tx -> - if cb_check tx - then return (Just True, n - i + 1) - else - let ns' = HashSet.union (ins tx) ns - in inputs (i - 1) is ns' ts - | otherwise -> inputs (i - 1) is ns ts - cb_check = any isCoinbase . (.inputs) - ins = HashSet.fromList . map (.outpoint.hash) . (.inputs) - height_check tx = - case tx.block of - BlockRef h _ -> h > height - MemRef _ -> True - --- POST Transaction -- - --- | Handler for @POST \/transactions@: broadcast a transaction to half of the peers and return its hash. -scottyPostTx :: (MonadUnliftIO m) => PostTx -> ActionT m TxId -scottyPostTx (PostTx tx) = - withMetrics (.txPost) $ do - cfg <- askl (.config) - lift (publishTx cfg tx) - return (TxId (txHash tx)) - --- | Send transaction to all connected peers. -publishTx :: - (MonadUnliftIO m, StoreReadBase m) => - WebConfig -> - Tx -> - m () -publishTx cfg tx = do - ps <- liftIO $ getPeers cfg.store.peerMgr - let c = max 1 (length ps `div` 2) - forM_ (take c ps) $ \p -> do - liftIO $ sendMessage (MTx tx) p.mailbox - void . async $ do - threadDelay (5 * 1000 * 1000) - let v = if cfg.store.net.segWit then InvWitnessTx else InvTx - g = MGetData (GetData [InvVector v (txHash tx).get]) - liftIO $ sendMessage g p.mailbox - --- GET Mempool / Events -- - --- | Handler for @GET \/mempool@: hashes of mempool transactions, newest first. -scottyMempool :: - (MonadUnliftIO m) => GetMempool -> ActionT m [TxHash] -scottyMempool (GetMempool limitM (OffsetParam o)) = - withMetrics (.mempool) $ do - WebLimits {..} <- askl (.config.limits) - let wl' = WebLimits {maxItemCount = 0, ..} - l = Limits (validateLimit wl' False limitM) (fromIntegral o) Nothing - map snd <$> getMempoolPage l - --- | Middleware that serves @\/events@ over a WebSocket: each new block or mempool --- transaction is sent as a JSON message. Clients that do not answer pings, or --- that fall more than 10000 events behind, are disconnected. -webSocketEvents :: WebState -> Middleware -webSocketEvents s = - websocketsOr defaultConnectionOptions (wrap . events) - where - pub = s.config.store.pub - pingPong = defaultPingPongOptions {pingInterval = 30, pongTimeout = 60} - gauge = (.events) <$> s.metrics - wrap f = case gauge of - Nothing -> f - Just g -> withGaugeIO g f - events pending = do - let path = requestPath $ pendingRequest pending - if path == "/events" - then withEventSubscription pub $ \next -> do - conn <- acceptRequest pending - -- Drop clients that stop answering pings, and clients that fall - -- so far behind that their event queue fills up. - -- websockets only sees pongs while reading, hence the reader. - withPingPong pingPong conn $ \c -> - let send_events = - next >>= \case - Nothing -> - WebSockets.sendClose c ("Event queue full" :: Text) - Just event -> do - sendTextData c (A.encode event) - send_events - in race_ - (loopForever (WebSockets.receiveDataMessage c)) - send_events - else - rejectRequestWith - pending - WebSockets.defaultRejectRequest - { WebSockets.rejectBody = - L.toStrict $ A.encode ThingNotFound, - WebSockets.rejectCode = - 404, - WebSockets.rejectMessage = - "Not Found", - WebSockets.rejectHeaders = - [("Content-Type", "application/json")] - } - --- | Handler for @GET \/events@: stream of new blocks and mempool transactions, one per line in JSON, until the client falls more than 10000 events behind. -scottyEvents :: (MonadUnliftIO m) => ActionT m () -scottyEvents = - withGaugeIncrease (.events) $ do - setHeaders - proto <- setupContentType False - pub <- askl (.config.store.pub) - S.stream $ \io flush' -> - withEventSubscription pub $ \next -> - -- ends the response when the client falls too far behind - let send_events = do - flush' - next >>= \case - Nothing -> return () - Just msg -> io (serial proto msg) >> send_events - in send_events - where - serial proto e = - lazyByteString $ - protoSerial proto toEncoding toJSON e <> newLine proto - newLine SerialAsBinary = mempty - newLine SerialAsJSON = "\n" - newLine SerialAsPrettyJSON = mempty - --- | Most events queued for one /events client. A client that does not keep --- up is disconnected once this many are waiting, instead of the queue --- growing without bound. -eventQueueSize :: Natural -eventQueueSize = 10000 - --- | Subscribe to the store events that /events clients see. The action gets --- a blocking read that returns the next event, or 'Nothing' once the queue --- has overflowed, after which the client must be disconnected. Other store --- events are dropped by the publisher instead of being queued. -withEventSubscription :: - Publisher StoreEvent -> (IO (Maybe Event) -> IO a) -> IO a -withEventSubscription pub f = do - inbox <- newBoundedInbox eventQueueSize - overflow <- newTVarIO False - let listen e = forM_ (toEvent e) $ \ev -> - mailboxFullSTM inbox >>= \case - True -> writeTVar overflow True - False -> sendSTM ev inbox - next = - atomically $ - (readTVar overflow >>= checkSTM >> return Nothing) - `orElse` (Just <$> receiveSTM inbox) - bracket (subscribe pub listen) (unsubscribe pub) $ \_ -> f next - where - toEvent = \case - StoreBestBlock b -> Just (EventBlock b) - StoreMempoolNew t -> Just (EventTx t) - StoreMempoolDelete t -> Just (EventTx t) - _ -> Nothing - --- GET Address Transactions -- - --- | Handler for @GET \/address\/:address\/transactions@: transactions of an address. -scottyAddrTxs :: - (MonadUnliftIO m) => GetAddrTxs -> ActionT m [TxRef] -scottyAddrTxs (GetAddrTxs addr pLimits) = - withMetrics (.addressTx) $ - getAddressTxs addr =<< paramToLimits False pLimits - --- | Handler for @GET \/address\/transactions?addresses=…@: transactions of several addresses. -scottyAddrsTxs :: - (MonadUnliftIO m) => GetAddrsTxs -> ActionT m [TxRef] -scottyAddrsTxs (GetAddrsTxs addrs pLimits) = - withMetrics (.addressTx) $ - getAddressesTxs addrs =<< paramToLimits False pLimits - --- | Handler for @GET \/address\/:address\/transactions\/full@: full transactions of an address. -scottyAddrTxsFull :: - (MonadUnliftIO m) => - GetAddrTxsFull -> - ActionT m [Transaction] -scottyAddrTxsFull (GetAddrTxsFull addr pLimits) = - withMetrics (.addressTxFull) $ do - txs <- getAddressTxs addr =<< paramToLimits True pLimits - catMaybes <$> getTransactions (map (.txid) txs) - --- | Handler for @GET \/address\/transactions\/full?addresses=…@: full transactions of several addresses. -scottyAddrsTxsFull :: - (MonadUnliftIO m) => - GetAddrsTxsFull -> - ActionT m [Transaction] -scottyAddrsTxsFull (GetAddrsTxsFull addrs pLimits) = - withMetrics (.addressTxFull) $ do - txs <- getAddressesTxs addrs =<< paramToLimits True pLimits - catMaybes <$> getTransactions (map (.txid) txs) - --- | Handler for @GET \/address\/:address\/balance@: balance of an address. -scottyAddrBalance :: (MonadUnliftIO m) => GetAddrBalance -> ActionT m Balance -scottyAddrBalance (GetAddrBalance addr) = - withMetrics (.addressBalance) $ getDefaultBalance addr - --- | Handler for @GET \/address\/balances?addresses=…@: balances of several addresses. -scottyAddrsBalance :: - (MonadUnliftIO m) => GetAddrsBalance -> ActionT m [Balance] -scottyAddrsBalance (GetAddrsBalance addrs) = - withMetrics (.addressBalance) $ getBalances addrs - --- | Handler for @GET \/address\/:address\/unspent@: unspent outputs of an address. -scottyAddrUnspent :: - (MonadUnliftIO m) => GetAddrUnspent -> ActionT m [Unspent] -scottyAddrUnspent (GetAddrUnspent addr pLimits) = - withMetrics (.addressUnspent) $ - getAddressUnspents addr =<< paramToLimits False pLimits - --- | Handler for @GET \/address\/unspent?addresses=…@: unspent outputs of several addresses. -scottyAddrsUnspent :: - (MonadUnliftIO m) => GetAddrsUnspent -> ActionT m [Unspent] -scottyAddrsUnspent (GetAddrsUnspent addrs pLimits) = - withMetrics (.addressUnspent) $ - getAddressesUnspents addrs =<< paramToLimits False pLimits - --- GET XPubs -- - --- | Handler for @GET \/xpub\/:xpub@: summary of an extended public key. -scottyXPub :: - (MonadUnliftIO m) => GetXPub -> ActionT m XPubSummary -scottyXPub (GetXPub xpub deriv (NoCache noCache)) = - withMetrics (.xpub) $ - let xs = XPubSpec xpub deriv - in xPubSummary xs <$> lift (runNoCache noCache $ xPubBals xs) - --- | Handler for @DELETE \/xpub\/:xpub@: remove an extended public key from the cache. Returns 'True' if it was cached. -scottyDelXPub :: - (MonadUnliftIO m) => - DelCachedXPub -> - ActionT m (GenericResult Bool) -scottyDelXPub (DelCachedXPub xpub deriv) = - withMetrics (.xpubDelete) $ do - c <- askl (.config.store.cache) - n <- lift (withCache c $ cacheDelXPubs [XPubSpec xpub deriv]) - return $ GenericResult (n > 0) - --- | Transactions of an extended public key, optionally without the cache. -getXPubTxs :: - (MonadUnliftIO m) => - XPubKey -> - DeriveType -> - LimitsParam -> - Bool -> - ActionT m [TxRef] -getXPubTxs xpub deriv plimits nocache = do - limits <- paramToLimits False plimits - let xs = XPubSpec xpub deriv - xbals <- xPubBals xs - lift $ runNoCache nocache $ xPubTxs xs xbals limits - --- | Handler for @GET \/xpub\/:xpub\/transactions@: transactions of an extended public key. -scottyXPubTxs :: - (MonadUnliftIO m) => GetXPubTxs -> ActionT m [TxRef] -scottyXPubTxs (GetXPubTxs xpub deriv plimits (NoCache nocache)) = - withMetrics (.xpubTx) $ - getXPubTxs xpub deriv plimits nocache - --- | Handler for @GET \/xpub\/:xpub\/transactions\/full@: full transactions of an extended public key. -scottyXPubTxsFull :: - (MonadUnliftIO m) => - GetXPubTxsFull -> - ActionT m [Transaction] -scottyXPubTxsFull (GetXPubTxsFull xpub deriv plimits (NoCache nocache)) = - withMetrics (.xpubTxFull) $ - fmap catMaybes $ - lift . runNoCache nocache . getTransactions . map (.txid) - =<< getXPubTxs xpub deriv plimits nocache - --- | Handler for @GET \/xpub\/:xpub\/balances@: balances of the used addresses of an extended public key. -scottyXPubBalances :: - (MonadUnliftIO m) => GetXPubBalances -> ActionT m [XPubBal] -scottyXPubBalances (GetXPubBalances xpub deriv (NoCache noCache)) = - withMetrics (.xpubBalance) $ - lift $ - runNoCache noCache $ - xPubBals (XPubSpec xpub deriv) - --- | Handler for @GET \/xpub\/:xpub\/unspent@: unspent outputs of an extended public key. -scottyXPubUnspent :: - (MonadUnliftIO m) => - GetXPubUnspent -> - ActionT m [XPubUnspent] -scottyXPubUnspent (GetXPubUnspent xpub deriv pLimits (NoCache noCache)) = - withMetrics (.xpubUnspent) $ do - limits <- paramToLimits False pLimits - let xspec = XPubSpec xpub deriv - xbals <- xPubBals xspec - lift $ runNoCache noCache $ xPubUnspents xspec xbals limits - ---------------------------------------- --- Blockchain.info API Compatibility -- ---------------------------------------- - --- | Currency symbol of the coin of a network, in the Blockchain.info format. -netBinfoSymbol :: Network -> BinfoSymbol -netBinfoSymbol net - | net == btc = - BinfoSymbol - { code = "BTC", - symbol = "BTC", - name = "Bitcoin", - conversion = 100 * 1000 * 1000, - after = True, - local = False - } - | net == bch = - BinfoSymbol - { code = "BCH", - symbol = "BCH", - name = "Bitcoin Cash", - conversion = 100 * 1000 * 1000, - after = True, - local = False - } - | otherwise = - BinfoSymbol - { code = "XTS", - symbol = "¤", - name = "Test", - conversion = 100 * 1000 * 1000, - after = False, - local = False - } - --- | Currency symbol of a fiat currency from its price ticker. -binfoTickerToSymbol :: Text -> BinfoTicker -> BinfoSymbol -binfoTickerToSymbol code t = - BinfoSymbol - { code, - symbol = t.symbol, - name, - conversion = 100 * 1000 * 1000 / t.fifteen, -- sat/usd - after = False, - local = True - } - where - name = case code of - "EUR" -> "Euro" - "USD" -> "U.S. dollar" - "GBP" -> "British pound" - x -> x - --- | Addresses and xpubs in a request parameter, separated by pipes or commas. -getBinfoAddrsParam :: - (MonadUnliftIO m) => - Text -> - ActionT m (HashSet BinfoAddr) -getBinfoAddrsParam name = do - net <- askl (.config.store.net) - ctx <- askl (.config.store.ctx) - p <- param name `rescue` return "" - if T.null p - then return HashSet.empty - else case parseBinfoAddr net ctx p of - Nothing -> raise (UserError "invalid address") - Just xs -> return $ HashSet.fromList xs - --- | Xpubs and addresses in the @active@, @activeP2SH@ and @activeBech32@ --- parameters. Xpubs in each parameter derive legacy, nested SegWit and native --- SegWit addresses. -getBinfoActive :: - (MonadUnliftIO m) => - ActionT m (HashSet XPubSpec, HashSet Address) -getBinfoActive = do - active <- getBinfoAddrsParam "active" - p2sh <- getBinfoAddrsParam "activeP2SH" - bech32 <- getBinfoAddrsParam "activeBech32" - let xspec d b = (`XPubSpec` d) <$> xpub b - xspecs = - HashSet.fromList $ - concat - [ mapMaybe (xspec DeriveNormal) (HashSet.toList active), - mapMaybe (xspec DeriveP2SH) (HashSet.toList p2sh), - mapMaybe (xspec DeriveP2WPKH) (HashSet.toList bech32) - ] - addrs = HashSet.fromList $ mapMaybe addr $ HashSet.toList active - return (xspecs, addrs) - where - addr (BinfoAddr a) = Just a - addr (BinfoXpub _) = Nothing - xpub (BinfoXpub x) = Just x - xpub (BinfoAddr _) = Nothing - --- | Whether to identify transactions by short number, unless @txidindex@ is false. -getNumTxId :: (MonadUnliftIO m) => ActionT m Bool -getNumTxId = fmap not $ param "txidindex" `rescue` return False - --- | Height of the best header. -getChainHeight :: (MonadUnliftIO m) => ActionT m H.BlockHeight -getChainHeight = - fmap (.height) $ liftIO . chainGetBest =<< askl (.config.store.chain) - --- | Handler for @GET\/POST \/blockchain\/unspent@: unspent outputs of addresses and xpubs, as Blockchain.info. -scottyBinfoUnspent :: (MonadUnliftIO m) => ActionT m () -scottyBinfoUnspent = - withMetrics (.binfoUnspent) $ do - (xspecs, addrs) <- getBinfoActive - numtxid <- getNumTxId - limit <- get_limit - min_conf <- get_min_conf - net <- askl (.config.store.net) - ctx <- askl (.config.store.ctx) - height <- getChainHeight - let mn u = min_conf > u.confirmations - xbals <- lift $ getXBals xspecs - bus <- - lift . runConduit $ - getBinfoUnspents numtxid height xbals xspecs addrs - .| (dropWhileC mn >> takeC limit .| sinkList) - setHeaders - streamEncoding (marshalEncoding (net, ctx) (BinfoUnspents bus)) - where - get_limit = fmap (min 1000) $ param "limit" `rescue` return 250 - get_min_conf = param "confirmations" `rescue` return 0 - --- | Stream the unspent outputs of xpubs and addresses, newest first, in the --- Blockchain.info format. -getBinfoUnspents :: - (StoreReadExtra m, MonadIO m) => - Bool -> - H.BlockHeight -> - HashMap XPubSpec [XPubBal] -> - HashSet XPubSpec -> - HashSet Address -> - ConduitT () BinfoUnspent m () -getBinfoUnspents numtxid height xbals xspecs addrs = do - cs' <- conduits - joinDescStreams cs' .| mapC (uncurry binfo) - where - binfo u xp = - let conf = case u.block of - MemRef _ -> 0 - BlockRef h _ -> height - h + 1 - in BinfoUnspent - { txid = u.outpoint.hash, - index = u.outpoint.index, - script = u.script, - value = u.value, - confirmations = fromIntegral conf, - txidx = encodeBinfoTxId numtxid u.outpoint.hash, - xpub = xp - } - conduits = (<>) <$> xconduits <*> pure acounduits - xconduits = lift $ do - let f x (XPubUnspent u p) = - let path = toSoft (listToPath p) - xp = BinfoXPubPath x.key <$> path - in (u, xp) - g x = do - let h = xPubUnspents x (xBals x xbals) - l = let Limits {..} = def in Limits {limit = 16, ..} - return $ streamThings h Nothing l .| mapC (f x) - mapM g (HashSet.toList xspecs) - acounduits = - let f u = (u, Nothing) - h = getAddressUnspents - l = let Limits {..} = def in Limits {limit = 16, ..} - g a = streamThings (h a) Nothing l .| mapC f - in map g (HashSet.toList addrs) - --- | Balances of the used addresses of each xpub. -getXBals :: - (StoreReadExtra m) => - HashSet XPubSpec -> - m (HashMap XPubSpec [XPubBal]) -getXBals = - fmap HashMap.fromList . mapM f . HashSet.toList - where - f x = (x,) . filter (not . nullBalance . (.balance)) <$> xPubBals x - --- | Balances of an xpub, or none if missing. -xBals :: XPubSpec -> HashMap XPubSpec [XPubBal] -> [XPubBal] -xBals = HashMap.findWithDefault [] - --- | Stream the transactions of xpubs and addresses, newest first, in the --- Blockchain.info format, with the running balance of the given addresses after --- each, keeping only those that pass the filter. -getBinfoTxs :: - (StoreReadExtra m, MonadIO m) => - HashMap XPubSpec [XPubBal] -> -- xpub balances - HashMap Address (Maybe BinfoXPubPath) -> -- address book - HashSet XPubSpec -> -- show xpubs - HashSet Address -> -- show addrs - HashSet Address -> -- balance addresses - BinfoFilter -> - Bool -> -- numtxid - Bool -> -- prune outputs - Int64 -> -- starting balance - ConduitT () BinfoTx m () -getBinfoTxs - xbals - abook - sxspecs - saddrs - baddrs - bfilter - numtxid - prune - bal = do - cs' <- conduits - joinDescStreams cs' .| go bal - where - sxspecs_ls = HashSet.toList sxspecs - saddrs_ls = HashSet.toList saddrs - conduits = - (<>) - <$> mapM xpub_c sxspecs_ls - <*> pure (map addr_c saddrs_ls) - xpub_c x = do - let f = xPubTxs x (xBals x xbals) - l = Limits {limit = 16, offset = 0, start = Nothing} - lift . return $ - streamThings f (Just (.txid)) l - addr_c a = do - let l = Limits {limit = 16, offset = 0, start = Nothing} - streamThings (getAddressTxs a) (Just (.txid)) l - binfo_tx = toBinfoTx numtxid abook prune - compute_bal_change t = - let ins = map (.output) t.inputs - out = t.outputs - f b BinfoTxOutput {..} = - let val = fromIntegral value - in case address of - Nothing -> 0 - Just a - | a `HashSet.member` baddrs -> - if b then val else negate val - | otherwise -> 0 - in sum $ map (f False) ins <> map (f True) out - go b = - await >>= \case - Nothing -> return () - Just (TxRef _ t) -> - lift (getTransaction t) >>= \case - Nothing -> go b - Just x -> do - let a = binfo_tx b x - b' = b - compute_bal_change a - c = isJust a.blockHeight - d = fst (fromJust a.balance) - r = d + fromIntegral a.fee - case bfilter of - BinfoFilterAll -> - yield a >> go b' - BinfoFilterSent - | 0 > r -> yield a >> go b' - | otherwise -> go b' - BinfoFilterReceived - | r > 0 -> yield a >> go b' - | otherwise -> go b' - BinfoFilterMoved - | r == 0 -> yield a >> go b' - | otherwise -> go b' - BinfoFilterConfirmed - | c -> yield a >> go b' - | otherwise -> go b' - BinfoFilterMempool - | c -> return () - | otherwise -> yield a >> go b' - --- | Whether to show addresses in CashAddr format (@cashaddr@). -getCashAddr :: (MonadUnliftIO m) => ActionT m Bool -getCashAddr = param "cashaddr" `rescue` return False - --- | Parse an address. Responds with not found if invalid. -getAddress :: (MonadUnliftIO m) => Text -> ActionT m Address -getAddress txt = do - net <- askl (.config.store.net) - case textToAddr net txt of - Nothing -> raise ThingNotFound - Just a -> return a - --- | Address or xpub in a path parameter. Passes to the next route if invalid. -getBinfoAddr :: (MonadUnliftIO m) => Text -> ActionT m BinfoAddr -getBinfoAddr param' = do - txt <- S.captureParam param' - net <- askl (.config.store.net) - ctx <- askl (.config.store.ctx) - let addr = BinfoAddr <$> textToAddr net txt - xpub = BinfoXpub <$> xPubImport net ctx txt - maybe S.next return (addr <|> xpub) - --- | Handler for @GET\/POST \/blockchain\/export-history@: daily history of the balance of addresses and xpubs with prices, as Blockchain.info. -scottyBinfoHistory :: (MonadUnliftIO m) => ActionT m () -scottyBinfoHistory = - withMetrics (.binfoExportHistory) $ do - (xspecs, addrs) <- getBinfoActive - (startM, endM) <- get_dates - (code, price') <- getPrice - xbals <- getXBals xspecs - let xaddrs = HashSet.fromList $ concatMap (map get_addr) (HashMap.elems xbals) - aaddrs = xaddrs <> addrs - cur = price'.fifteen - cs' = conduits (HashMap.toList xbals) addrs endM - txs <- - lift $ - runConduit $ - joinDescStreams cs' - .| takeWhileC (is_newer startM) - .| concatMapMC get_transaction - .| sinkList - let times = map (\Transaction {..} -> timestamp) txs - net <- askl (.config.store.net) - url <- askl (.config.priceHistoryURL) - session <- askl (.session) - logger <- askl (.config.logger) - rates <- map (.price) <$> lift (getRates logger net session url code times) - let hs = zipWith (convert cur aaddrs) txs (rates <> repeat 0.0) - setHeaders - streamEncoding $ toEncoding hs - where - is_newer - (Just BlockData {height = bh}) - TxRef {block = BlockRef {height = th}} = - bh <= th - is_newer Nothing TxRef {} = True - is_newer _ _ = undefined - get_addr = (.balance.address) - get_transaction TxRef {txid = h} = - getTransaction h - convert cur addrs tx rate = - let ins = tx.inputs - outs = tx.outputs - fins = filter (input_addr addrs) ins - fouts = filter (output_addr addrs) outs - vin = fromIntegral . sum $ map (.value) fins - vout = fromIntegral . sum $ map (.value) fouts - fee = tx.fee - v = vout - vin - t = tx.timestamp - h = txHash $ transactionData tx - in toBinfoHistory v t rate cur fee h - input_addr addrs' StoreInput {address = Just a} = - a `HashSet.member` addrs' - input_addr _ _ = False - output_addr addrs' StoreOutput {address = Just a} = - a `HashSet.member` addrs' - output_addr _ _ = False - get_dates = do - BinfoDate start <- param "start" - BinfoDate end' <- param "end" - let end = end' + 24 * 60 * 60 - ch <- askl (.config.store.chain) - startM <- blockAtOrAfter ch start - endM <- blockAtOrBefore ch end - return (startM, endM) - conduits xpubs addrs endM = - map (uncurry (xpub_c endM)) xpubs - <> map (addr_c endM) (HashSet.toList addrs) - lim endM = - Limits - { limit = 16, - offset = 0, - start = AtBlock . (.height) <$> endM - } - addr_c endM a = - streamThings (getAddressTxs a) (Just (.txid)) (lim endM) - xpub_c endM x bs = - streamThings (xPubTxs x bs) (Just (.txid)) (lim endM) - --- | Currency code in the @currency@ parameter, USD by default, and its latest price. -getPrice :: (MonadUnliftIO m) => ActionT m (Text, BinfoTicker) -getPrice = do - code <- T.toUpper <$> param "currency" `rescue` return "USD" - ticker <- askl (.ticker) - prices <- readTVarIO ticker - case HashMap.lookup code prices of - Nothing -> return (code, def) - Just p -> return (code, p) - --- | Symbol of the currency in the @currency@ parameter. -getSymbol :: (MonadUnliftIO m) => ActionT m BinfoSymbol -getSymbol = uncurry binfoTickerToSymbol <$> getPrice - --- | Handler for @GET \/blockchain\/blocks\/:milliseconds@: the blocks of the day before a time in milliseconds, as Blockchain.info. -scottyBinfoBlocksDay :: (MonadUnliftIO m) => ActionT m () -scottyBinfoBlocksDay = - withMetrics (.binfoBlock) $ do - t <- min h . (`div` 1000) <$> S.captureParam "milliseconds" - ch <- askl (.config.store.chain) - m <- blockAtOrBefore ch t - bs <- go (d t) m - streamEncoding $ toEncoding $ map toBinfoBlockInfo bs - where - h = fromIntegral (maxBound :: H.Timestamp) - d = subtract (24 * 3600) - go _ Nothing = return [] - go t (Just b) - | b.header.timestamp <= fromIntegral t = - return [] - | otherwise = do - b' <- getBlock b.header.prev - (b :) <$> go t b' - --- | Handler for @GET\/POST \/blockchain\/multiaddr@: balances and transactions of addresses and xpubs, as Blockchain.info. -scottyMultiAddr :: (MonadUnliftIO m) => ActionT m () -scottyMultiAddr = - withMetrics (.binfoMultiaddr) $ do - (addrs', _, saddrs, sxpubs, xspecs) <- get_addrs - numtxid <- getNumTxId - cashaddr <- getCashAddr - local' <- getSymbol - offset <- getBinfoOffset - n <- getBinfoCount "n" - prune <- get_prune - fltr <- get_filter - xbals <- getXBals xspecs - xtxns <- get_xpub_tx_count xbals xspecs - let sxbals = only_show_xbals sxpubs xbals - xabals = compute_xabals xbals - addrs = addrs' `HashSet.difference` HashMap.keysSet xabals - abals <- get_abals addrs - let sxspecs = only_show_xspecs sxpubs xspecs - sxabals = compute_xabals sxbals - sabals = only_show_abals saddrs abals - sallbals = sabals <> sxabals - sbal = compute_bal sallbals - allbals = abals <> xabals - abook = compute_abook addrs xbals - sxaddrs = compute_xaddrs sxbals - salladdrs = saddrs <> sxaddrs - bal = compute_bal allbals - ibal = fromIntegral sbal - ftxs <- - lift . runConduit $ - getBinfoTxs - xbals - abook - sxspecs - saddrs - salladdrs - fltr - numtxid - prune - ibal - .| (dropC offset >> takeC n .| sinkList) - net <- askl (.config.store.net) - ctx <- askl (.config.store.ctx) - best <- get_best_block - peers <- get_peers - let baddrs = toBinfoAddrs sabals sxbals xtxns - abaddrs = toBinfoAddrs abals xbals xtxns - recv = sum $ map (.received) abaddrs - sent' = sum $ map (.sent) abaddrs - txn = fromIntegral $ length ftxs - wallet = - BinfoWallet - { balance = bal, - txs = txn, - filtered = txn, - received = recv, - sent = sent' - } - coin = netBinfoSymbol net - let block = - BinfoBlockInfo - { hash = H.headerHash best.header, - height = best.height, - timestamp = best.header.timestamp, - index = best.height - } - let info = - BinfoInfo - { connected = peers, - conversion = 100 * 1000 * 1000, - fiat = local', - crypto = coin, - head = block - } - let multiaddr = - BinfoMultiAddr - { addresses = baddrs, - wallet = wallet, - txs = ftxs, - info = info, - recommendFee = True, - cashAddr = cashaddr - } - setHeaders - streamEncoding $ marshalEncoding (net, ctx) multiaddr - where - get_xpub_tx_count xbals = - fmap HashMap.fromList - . mapM - ( \x -> - (x,) - . fromIntegral - <$> xPubTxCount x (xBals x xbals) - ) - . HashSet.toList - get_filter = param "filter" `rescue` return BinfoFilterAll - get_best_block = - getBestBlock >>= \case - Nothing -> raise ThingNotFound - Just bh -> - getBlock bh >>= \case - Nothing -> raise ThingNotFound - Just b -> return b - get_prune = - fmap not $ - param "noCompact" - `rescue` param "no_compact" - `rescue` return False - only_show_xbals sxpubs = - HashMap.filterWithKey (\k _ -> k.key `HashSet.member` sxpubs) - only_show_xspecs sxpubs = - HashSet.filter (\k -> k.key `HashSet.member` sxpubs) - only_show_abals saddrs = - HashMap.filterWithKey (\k _ -> k `HashSet.member` saddrs) - addr (BinfoAddr a) = Just a - addr (BinfoXpub _) = Nothing - xpub (BinfoXpub x) = Just x - xpub (BinfoAddr _) = Nothing - get_addrs = do - (xspecs, addrs) <- getBinfoActive - sh <- getBinfoAddrsParam "onlyShow" - let xpubs = HashSet.map (.key) xspecs - actives = - HashSet.map BinfoAddr addrs - <> HashSet.map BinfoXpub xpubs - sh' = if HashSet.null sh then actives else sh - saddrs = HashSet.fromList $ mapMaybe addr $ HashSet.toList sh' - sxpubs = HashSet.fromList $ mapMaybe xpub $ HashSet.toList sh' - return (addrs, xpubs, saddrs, sxpubs, xspecs) - get_abals = - let f b = (b.address, b) - g = HashMap.fromList . map f - in fmap g . getBalances . HashSet.toList - get_peers = do - ps <- lift $ getPeersInformation =<< asks (.config.store.peerMgr) - return (fromIntegral (length ps)) - compute_xabals = - let f b = (b.balance.address, b.balance) - in HashMap.fromList . concatMap (map f) . HashMap.elems - compute_bal = - let f b = b.confirmed + b.unconfirmed - in sum . map f . HashMap.elems - compute_abook addrs xbals = - let f xs xb = - let a = xb.balance.address - e = error "lions and tigers and bears" - s = toSoft (listToPath xb.path) - in (a, Just (BinfoXPubPath xs.key (fromMaybe e s))) - amap = - HashMap.map (const Nothing) $ - HashSet.toMap addrs - xmap = - HashMap.fromList - . concatMap (uncurry (map . f)) - $ HashMap.toList xbals - in amap <> xmap - compute_xaddrs = - let f = map (.balance.address) - in HashSet.fromList . concatMap f . HashMap.elems - --- | Number of items requested in a parameter, within the limits. -getBinfoCount :: (MonadUnliftIO m) => Text -> ActionT m Int -getBinfoCount str = do - d <- askl (.config.limits.defItemCount) - x <- askl (.config.limits.maxFullItemCount) - i <- min x <$> (param str `rescue` return d) - return (fromIntegral i :: Int) - --- | Offset requested in the @offset@ parameter. Responds with an error if above the maximum. -getBinfoOffset :: - (MonadUnliftIO m) => - ActionT m Int -getBinfoOffset = do - x <- askl (.config.limits.maxOffset) - o <- param "offset" `rescue` return 0 - when (o > x) $ - raise $ - UserError $ - "offset exceeded: " <> show o <> " > " <> show x - return (fromIntegral o :: Int) - --- | Handler for @GET \/blockchain\/rawaddr\/:addr@: balance and transactions of an address or xpub, as Blockchain.info; also at @\/blockchain\/address\/:addr@ and @\/blockchain\/xpub\/:addr@. -scottyRawAddr :: (MonadUnliftIO m) => ActionT m () -scottyRawAddr = - withMetrics (.binfoAddressRaw) $ - getBinfoAddr "addr" >>= \case - BinfoAddr addr -> do_addr addr - BinfoXpub xpub -> do_xpub xpub - where - do_xpub xpub = do - numtxid <- getNumTxId - derive <- param "derive" `rescue` return DeriveNormal - let xspec = XPubSpec xpub derive - n <- getBinfoCount "limit" - off <- getBinfoOffset - xbals <- getXBals $ HashSet.singleton xspec - net <- askl (.config.store.net) - let summary = xPubSummary xspec (xBals xspec xbals) - abook = compute_abook xpub (xBals xspec xbals) - xspecs = HashSet.singleton xspec - saddrs = HashSet.empty - baddrs = HashMap.keysSet abook - bfilter = BinfoFilterAll - amnt = summary.confirmed + summary.unconfirmed - txs <- - lift $ - runConduit $ - getBinfoTxs - xbals - abook - xspecs - saddrs - baddrs - bfilter - numtxid - False - (fromIntegral amnt) - .| (dropC off >> takeC n .| sinkList) - let ra = - BinfoRawAddr - { address = BinfoXpub xpub, - balance = amnt, - ntx = fromIntegral $ length txs, - utxo = summary.utxo, - received = summary.received, - sent = fromIntegral summary.received - fromIntegral amnt, - txs = txs - } - setHeaders - ctx <- askl (.config.store.ctx) - streamEncoding $ marshalEncoding (net, ctx) ra - compute_abook xpub xbals = - let f xb = - let a = xb.balance.address - e = error "black hole swallows all your code" - s = toSoft $ listToPath xb.path - m = fromMaybe e s - in (a, Just (BinfoXPubPath xpub m)) - in HashMap.fromList $ map f xbals - do_addr addr = do - numtxid <- getNumTxId - n <- getBinfoCount "limit" - off <- getBinfoOffset - bal <- fromMaybe (zeroBalance addr) <$> getBalance addr - net <- askl (.config.store.net) - let abook = HashMap.singleton addr Nothing - xspecs = HashSet.empty - saddrs = HashSet.singleton addr - bfilter = BinfoFilterAll - balance = bal.confirmed + bal.unconfirmed - txs <- - lift . runConduit $ - getBinfoTxs - HashMap.empty - abook - xspecs - saddrs - saddrs - bfilter - numtxid - False - (fromIntegral balance) - .| (dropC off >> takeC n .| sinkList) - let ra = - BinfoRawAddr - { address = BinfoAddr addr, - balance, - ntx = bal.txs, - utxo = bal.utxo, - received = bal.received, - sent = fromIntegral bal.received - fromIntegral balance, - txs - } - setHeaders - ctx <- askl (.config.store.ctx) - streamEncoding $ marshalEncoding (net, ctx) ra - --- | Handler for @GET \/blockchain\/q\/getreceivedbyaddress\/:addr@: total received by an address. -scottyBinfoReceived :: (MonadUnliftIO m) => ActionT m () -scottyBinfoReceived = - withMetrics (.binfoQgetreceivedbyaddress) $ do - a <- getAddress =<< S.captureParam "addr" - b <- fromMaybe (zeroBalance a) <$> getBalance a - setHeaders - S.text $ cs $ show b.received - --- | Handler for @GET \/blockchain\/q\/getsentbyaddress\/:addr@: total sent by an address. -scottyBinfoSent :: (MonadUnliftIO m) => ActionT m () -scottyBinfoSent = - withMetrics (.binfoQgetsentbyaddress) $ do - a <- getAddress =<< S.captureParam "addr" - b <- fromMaybe (zeroBalance a) <$> getBalance a - setHeaders - S.text $ cs $ show $ b.received - b.confirmed - b.unconfirmed - --- | Handler for @GET \/blockchain\/q\/addressbalance\/:addr@: balance of an address. -scottyBinfoAddrBalance :: (MonadUnliftIO m) => ActionT m () -scottyBinfoAddrBalance = - withMetrics (.binfoQaddressbalance) $ do - a <- getAddress =<< S.captureParam "addr" - b <- fromMaybe (zeroBalance a) <$> getBalance a - setHeaders - S.text $ cs $ show $ b.confirmed + b.unconfirmed - --- | Handler for @GET \/blockchain\/q\/addressfirstseen\/:addr@: time of the first block with a transaction of an address. -scottyFirstSeen :: (MonadUnliftIO m) => ActionT m () -scottyFirstSeen = - withMetrics (.binfoQaddressfirstseen) $ do - a <- getAddress =<< S.captureParam "addr" - ch <- askl (.config.store.chain) - bb <- liftIO $ chainGetBest ch - let top = bb.height - bot = 0 - i <- go ch bb a bot top - setHeaders - S.text $ cs $ show i - where - go ch bb a bot top = do - let mid = bot + (top - bot) `div` 2 - n = top - bot < 2 - x <- hasone a bot - y <- hasone a mid - z <- hasone a top - if - | x -> getblocktime ch bb bot - | n -> getblocktime ch bb top - | y -> go ch bb a bot mid - | z -> go ch bb a mid top - | otherwise -> return 0 - getblocktime ch bb h = - liftIO (chainGetAncestor ch h bb) >>= \case - Just b -> return b.header.timestamp - Nothing -> do - logger <- askl (.config.logger) - logError logger $ - "Could not get ancestor at height " - <> cs (show h) - <> " for block " - <> H.blockHashToHex (H.headerHash bb.header) - error "Block ancestor retreival error" - hasone a h = do - let l = Limits 1 0 (Just (AtBlock h)) - not . null <$> getAddressTxs a l - --- | Handler for @GET\/POST \/blockchain\/balance@: short balances of addresses and xpubs, as Blockchain.info. -scottyShortBal :: (MonadUnliftIO m) => ActionT m () -scottyShortBal = - withMetrics (.binfoBalance) $ do - (xspecs, addrs) <- getBinfoActive - cashaddr <- getCashAddr - net <- askl (.config.store.net) - abals <- catMaybes <$> mapM (getabal net cashaddr) (HashSet.toList addrs) - xbals <- mapM (getxbal net) (HashSet.toList xspecs) - let res = HashMap.fromList (abals <> xbals) - setHeaders - streamEncoding $ toEncoding res - where - shorten bal = - BinfoShortBal - { final = bal.confirmed + bal.unconfirmed, - ntx = bal.txs, - received = bal.received - } - getabal net cashaddr a = - let net' = - if - | cashaddr -> net - | net == bch -> btc - | net == bchTest -> btcTest - | net == bchTest4 -> btcTest - | otherwise -> net - in case addrToText net' a of - Nothing -> return Nothing - Just a' -> - getBalance a >>= \case - Nothing -> return $ Just (a', shorten (zeroBalance a)) - Just b -> return $ Just (a', shorten b) - getxbal net xpub = do - xbals <- xPubBals xpub - ntx <- fromIntegral <$> xPubTxCount xpub xbals - let val = sum $ map (.balance.confirmed) xbals - zro = sum $ map (.balance.unconfirmed) xbals - exs = [x | x@XPubBal {path = 0 : _} <- xbals] - final = val + zro - received = sum $ map (.balance.received) exs - sbl = BinfoShortBal {final, ntx, received} - ctx <- askl (.config.store.ctx) - return (xPubExport net ctx xpub.key, sbl) - --- | Whether to respond with hex (@format=hex@). -getBinfoHex :: (MonadUnliftIO m) => ActionT m Bool -getBinfoHex = (== ("hex" :: Text)) <$> param "format" `rescue` return "json" - --- | Handler for @GET \/blockchain\/block-height\/:height@: the blocks at a height, as Blockchain.info. -scottyBinfoBlockHeight :: (MonadUnliftIO m) => ActionT m () -scottyBinfoBlockHeight = - withMetrics (.binfoBlockHeight) $ do - numtxid <- getNumTxId - height <- S.captureParam "height" - bs <- fmap catMaybes $ getBlocksAtHeight height >>= mapM getBlock - ns <- fmap catMaybes $ getBlocksAtHeight (height + 1) >>= mapM getBlock - is <- mapM (get_binfo_blocks numtxid ns) bs - setHeaders - net <- askl (.config.store.net) - ctx <- askl (.config.store.ctx) - streamEncoding $ marshalEncoding (net, ctx) is - where - get_binfo_blocks numtxid ns b = do - txs <- catMaybes <$> getTransactions b.txs - let h x = H.headerHash x.header - nbs = [h n | n <- ns, n.header.prev == h b] - bts = map (toBinfoTxSimple numtxid) txs - return $ toBinfoBlock b bts nbs - --- | Handler for @GET \/blockchain\/latestblock@: the best block, as Blockchain.info. -scottyBinfoLatest :: (MonadUnliftIO m) => ActionT m () -scottyBinfoLatest = - withMetrics (.binfoBlockLatest) $ do - numtxid <- getNumTxId - mb <- runMaybeT $ MaybeT getBestBlock >>= MaybeT . getBlock - b <- maybe (raise ThingNotFound) return mb - streamEncoding $ - toEncoding - BinfoHeader - { hash = H.headerHash b.header, - timestamp = b.header.timestamp, - index = b.height, - height = b.height, - txids = map (encodeBinfoTxId numtxid) b.txs - } - --- | Handler for @GET \/blockchain\/rawblock\/:block@: a block with its transactions, as Blockchain.info. -scottyBinfoBlock :: (MonadUnliftIO m) => ActionT m () -scottyBinfoBlock = - withMetrics (.binfoBlockRaw) $ do - numtxid <- getNumTxId - hex <- getBinfoHex - S.captureParam "block" >>= \case - BinfoBlockHash bh -> go numtxid hex bh - BinfoBlockIndex i -> - getBlocksAtHeight i >>= \case - [] -> raise ThingNotFound - bh : _ -> go numtxid hex bh - where - go numtxid hex bh = do - b <- maybe (raise ThingNotFound) return =<< getBlock bh - txs <- catMaybes <$> getTransactions b.txs - nhs <- fmap catMaybes $ getBlocksAtHeight (b.height + 1) >>= mapM getBlock - let h x = H.headerHash x.header - nxt = [h n | n <- nhs, n.header.prev == h b] - if hex - then do - let x = H.Block b.header (map transactionData txs) - setHeaders - S.text . encodeHexLazy . runPutL $ serialize x - else do - let bts = map (toBinfoTxSimple numtxid) txs - y = toBinfoBlock b bts nxt - setHeaders - net <- askl (.config.store.net) - ctx <- askl (.config.store.ctx) - streamEncoding $ marshalEncoding (net, ctx) y - --- | Transaction by hash or short number. Fails with 'TxIndexConflict' if a short number matches several. -getBinfoTx :: - (MonadUnliftIO m) => - BinfoTxId -> - ActionT m (Either Except Transaction) -getBinfoTx txid = do - tx <- case txid of - BinfoTxIdHash h -> maybeToList <$> getTransaction h - BinfoTxIdIndex i -> getNumTransaction i - case tx of - [t] -> return $ Right t - [] -> return $ Left ThingNotFound - ts -> - let tids = map (txHash . transactionData) ts - in return $ Left (TxIndexConflict tids) - --- | Handler for @GET \/blockchain\/rawtx\/:txid@: a transaction, as Blockchain.info. -scottyBinfoTx :: (MonadUnliftIO m) => ActionT m () -scottyBinfoTx = - withMetrics (.binfoTxRaw) $ do - numtxid <- getNumTxId - hex <- getBinfoHex - txid <- S.captureParam "txid" - tx <- - getBinfoTx txid >>= \case - Right t -> return t - Left e -> raise e - if hex then hx tx else js numtxid tx - where - js numtxid t = do - net <- askl (.config.store.net) - ctx <- askl (.config.store.ctx) - setHeaders - streamEncoding $ marshalEncoding (net, ctx) $ toBinfoTxSimple numtxid t - hx t = do - setHeaders - S.text . encodeHexLazy . runPutL . serialize $ transactionData t - --- | Handler for @GET \/blockchain\/q\/txtotalbtcoutput\/:txid@: total value of the outputs of a transaction. -scottyBinfoTotalOut :: (MonadUnliftIO m) => ActionT m () -scottyBinfoTotalOut = - withMetrics (.binfoQtxtotalbtcoutput) $ do - txid <- S.captureParam "txid" - tx <- - getBinfoTx txid >>= \case - Right t -> return t - Left e -> raise e - S.text $ cs $ show $ sum $ map (.value) tx.outputs - --- | Handler for @GET \/blockchain\/q\/txfee\/:txid@: fee of a transaction. -scottyBinfoTxFees :: (MonadUnliftIO m) => ActionT m () -scottyBinfoTxFees = - withMetrics (.binfoQtxfee) $ do - txid <- S.captureParam "txid" - tx <- - getBinfoTx txid >>= \case - Right t -> return t - Left e -> raise e - let i = sum $ map (.value) $ filter f tx.inputs - o = sum $ map (.value) tx.outputs - S.text . cs . show $ i - o - where - f StoreInput {} = True - f StoreCoinbase {} = False - --- | Handler for @GET \/blockchain\/q\/txresult\/:txid\/:addr@: net amount that a transaction sends to an address. -scottyBinfoTxResult :: (MonadUnliftIO m) => ActionT m () -scottyBinfoTxResult = - withMetrics (.binfoQtxresult) $ do - txid <- S.captureParam "txid" - addr <- getAddress =<< S.captureParam "addr" - tx <- - getBinfoTx txid >>= \case - Right t -> return t - Left e -> raise e - let i = toInteger $ sum $ map (.value) $ filter (f addr) tx.inputs - o = toInteger $ sum $ map (.value) $ filter (g addr) tx.outputs - S.text $ cs $ show $ o - i - where - f addr StoreInput {address = Just a} = a == addr - f _ _ = False - g addr StoreOutput {address = Just a} = a == addr - g _ _ = False - --- | Handler for @GET \/blockchain\/q\/txtotalbtcinput\/:txid@: total value of the inputs of a transaction. -scottyBinfoTotalInput :: (MonadUnliftIO m) => ActionT m () -scottyBinfoTotalInput = - withMetrics (.binfoQtxtotalbtcinput) $ do - txid <- S.captureParam "txid" - tx <- - getBinfoTx txid >>= \case - Right t -> return t - Left e -> raise e - S.text $ cs $ show $ sum $ map (.value) $ filter f $ tx.inputs - where - f StoreInput {} = True - f StoreCoinbase {} = False - --- | Handler for @GET \/blockchain\/unconfirmed-transactions@: mempool transactions, as Blockchain.info. -scottyBinfoMempool :: (MonadUnliftIO m) => ActionT m () -scottyBinfoMempool = - withMetrics (.binfoMempool) $ do - numtxid <- getNumTxId - offset <- getBinfoOffset - n <- getBinfoCount "limit" - -- a limit of 0 would mean no limit to getMempoolPage - txids <- - if n <= 0 - then return [] - else - map snd - <$> getMempoolPage (Limits (fromIntegral n) (fromIntegral offset) Nothing) - txs <- catMaybes <$> getTransactions txids - net <- askl (.config.store.net) - setHeaders - let mem = BinfoMempool $ map (toBinfoTxSimple numtxid) txs - ctx <- askl (.config.store.ctx) - streamEncoding $ marshalEncoding (net, ctx) mem - --- | Handler for @GET \/blockchain\/q\/getblockcount@: height of the best header. -scottyBinfoGetBlockCount :: (MonadUnliftIO m) => ActionT m () -scottyBinfoGetBlockCount = - withMetrics (.binfoQgetblockcount) $ do - ch <- askl (.config.store.chain) - bn <- liftIO $ chainGetBest ch - setHeaders - S.text $ TL.pack $ show bn.height - --- | Handler for @GET \/blockchain\/q\/latesthash@: hash of the best header. -scottyBinfoLatestHash :: (MonadUnliftIO m) => ActionT m () -scottyBinfoLatestHash = - withMetrics (.binfoQlatesthash) $ do - ch <- askl (.config.store.chain) - bn <- liftIO $ chainGetBest ch - setHeaders - S.text $ TL.fromStrict $ H.blockHashToHex $ H.headerHash bn.header - --- | Handler for @GET \/blockchain\/q\/bcperblock@: block subsidy at the next height. -scottyBinfoSubsidy :: (MonadUnliftIO m) => ActionT m () -scottyBinfoSubsidy = - withMetrics (.binfoQbcperblock) $ do - ch <- askl (.config.store.chain) - net <- askl (.config.store.net) - bn <- liftIO $ chainGetBest ch - setHeaders - S.text $ - cs $ - show $ - (/ (100 * 1000 * 1000 :: Double)) $ - fromIntegral $ - H.computeSubsidy net (bn.height + 1) - --- | Handler for @GET \/blockchain\/q\/addresstohash\/:addr@: hash160 of an address in hex. -scottyBinfoAddrToHash :: (MonadUnliftIO m) => ActionT m () -scottyBinfoAddrToHash = - withMetrics (.binfoQaddresstohash) $ do - addr <- getAddress =<< S.captureParam "addr" - setHeaders - if - | Just h <- addressHash160 addr -> - S.text $ encodeHexLazy $ runPutL $ serialize h - | Just h <- addressHash256 addr -> - S.text $ encodeHexLazy $ runPutL $ serialize h - | otherwise -> - return () - --- | Handler for @GET \/blockchain\/q\/hashtoaddress\/:hash@: pay-to-public-key-hash address of a hash160. -scottyBinfoHashToAddr :: (MonadUnliftIO m) => ActionT m () -scottyBinfoHashToAddr = - withMetrics (.binfoQhashtoaddress) $ do - bs <- maybe S.next return . decodeHex =<< S.captureParam "hash" - net <- askl (.config.store.net) - hash <- either (const S.next) return $ decode bs - addr <- maybe S.next return $ addrToText net $ PubKeyAddress hash - setHeaders - S.text $ TL.fromStrict addr - --- | Handler for @GET \/blockchain\/q\/addrpubkey\/:pubkey@: address of a public key. -scottyBinfoAddrPubkey :: (MonadUnliftIO m) => ActionT m () -scottyBinfoAddrPubkey = - withMetrics (.binfoQaddrpubkey) $ do - hex <- S.captureParam "pubkey" - ctx <- askl (.config.store.ctx) - pubkey <- - maybe S.next (return . pubKeyAddr ctx) $ - eitherToMaybe . unmarshal ctx =<< decodeHex hex - net <- askl (.config.store.net) - setHeaders - case addrToText net pubkey of - Nothing -> raise ThingNotFound - Just a -> S.text $ TL.fromStrict a - --- | Handler for @GET \/blockchain\/q\/pubkeyaddr\/:addr@: public key of an address, found in a transaction input that spends from it. -scottyBinfoPubKeyAddr :: (MonadUnliftIO m) => ActionT m () -scottyBinfoPubKeyAddr = - withMetrics (.binfoQpubkeyaddr) $ do - addr <- getAddress =<< S.captureParam "addr" - mi <- strm addr - i <- case mi of - Nothing -> raise ThingNotFound - Just i -> return i - pk <- case extr addr i of - Left e -> raise $ UserError e - Right t -> return t - setHeaders - S.text $ encodeHexLazy $ L.fromStrict pk - where - strm addr = do - runConduit $ do - let l = Limits {limit = 8, offset = 0, start = Nothing} - streamThings (getAddressTxs addr) (Just (.txid)) l - .| concatMapMC (getTransaction . (.txid)) - .| concatMapC (filter (inp addr) . (.inputs)) - .| headC - inp addr StoreInput {address = Just a} = a == addr - inp _ _ = False - extr addr StoreInput {script, pkscript, witness} = do - Script sig <- decode script - Script pks <- decode pkscript - case addr of - PubKeyAddress {} -> - case sig of - [OP_PUSHDATA _ _, OP_PUSHDATA pub _] -> - Right pub - [OP_PUSHDATA _ _] -> - case pks of - [OP_PUSHDATA pub _, OP_CHECKSIG] -> - Right pub - _ -> Left "Could not parse scriptPubKey" - _ -> Left "Could not parse scriptSig" - WitnessPubKeyAddress {} -> - case witness of - [_, pub] -> return pub - _ -> Left "Could not parse scriptPubKey" - _ -> Left "Address does not have public key" - extr _ _ = Left "Incorrect input type" - --- | Handler for @GET \/blockchain\/q\/hashpubkey\/:pubkey@: hash160 of a public key in hex. -scottyBinfoHashPubkey :: (MonadUnliftIO m) => ActionT m () -scottyBinfoHashPubkey = - withMetrics (.binfoQhashpubkey) $ do - ctx <- askl (.config.store.ctx) - pkm <- - fmap - (eitherToMaybe . unmarshal ctx <=< decodeHex) - (S.captureParam "pubkey") - addr <- case pkm of - Nothing -> raise $ UserError "Could not decode public key" - Just pk -> return $ pubKeyAddr ctx pk - setHeaders - if - | Just h <- addressHash160 addr -> - S.text $ encodeHexLazy $ runPutL $ serialize h - | Just h <- addressHash256 addr -> - S.text $ encodeHexLazy $ runPutL $ serialize h - | otherwise -> - return () - --- GET Network Information -- - --- | Handler for @GET \/peers@: connected peers. -scottyPeers :: - (MonadUnliftIO m) => - GetPeers -> - ActionT m [PeerInfo] -scottyPeers _ = - withMetrics (.peers) $ do - lift . getPeersInformation =<< askl (.config.store.peerMgr) - --- | Obtain information about connected peers from peer manager process. -getPeersInformation :: - (MonadIO m) => PeerMgr -> m [PeerInfo] -getPeersInformation mgr = - mapMaybe toInfo <$> liftIO (getPeers mgr) - where - toInfo op = do - ver <- op.version - return - PeerInfo - { userAgent = ver.userAgent.get, - address = show op.address, - -- Signed, as the peer sent it. See 'PeerInfo'. - version = ver.version, - services = ver.services, - relay = ver.relay - } - --- | Handler for @GET \/health@: health of the store. -scottyHealth :: - (MonadUnliftIO m) => GetHealth -> ActionT m HealthCheck -scottyHealth _ = - withMetrics (.health) $ do - h <- askl (.health) >>= readTVarIO - unless (isOK h) $ S.status status503 - return h - --- | Heights of the best header and best block, and the maximum lag allowed. -blockHealthCheck :: - (MonadUnliftIO m, StoreReadBase m) => - WebConfig -> - m BlockHealth -blockHealthCheck cfg = do - let ch = cfg.store.chain - headers <- (.height) <$> liftIO (chainGetBest ch) - blocks <- - maybe 0 (.height) - <$> runMaybeT (MaybeT getBestBlock >>= MaybeT . getBlock) - return - BlockHealth - { headers, - blocks, - max = fromIntegral cfg.maxLaggingBlocks - } - --- | Age of the best header and the maximum allowed. -lastBlockHealthCheck :: - (MonadUnliftIO m, StoreReadBase m) => - Chain -> - WebLimits -> - m TimeHealth -lastBlockHealthCheck ch WebLimits {blockTimeout} = do - n <- round <$> liftIO getPOSIXTime - t <- fromIntegral . (.header.timestamp) <$> liftIO (chainGetBest ch) - return - TimeHealth - { age = n - t, - max = fromIntegral blockTimeout - } - --- | Age of the newest mempool transaction or best header, and the maximum allowed. -lastTxHealthCheck :: - (MonadUnliftIO m, StoreReadBase m) => - WebConfig -> - m TimeHealth -lastTxHealthCheck WebConfig {noMempool, store = store', limits} = do - n <- round <$> liftIO getPOSIXTime - b <- fromIntegral . (.header.timestamp) <$> liftIO (chainGetBest ch) - t <- - getMempoolPage (Limits 1 0 Nothing) >>= \case - t : _ -> - let x = fromIntegral $ fst t - in return $ max x b - [] -> return b - return - TimeHealth - { age = n - t, - max = fromIntegral to - } - where - ch = store'.chain - to = - if noMempool - then limits.blockTimeout - else limits.txTimeout - --- | Transactions waiting to be imported and the maximum allowed. -pendingTxsHealthCheck :: - (MonadUnliftIO m, StoreReadBase m) => - WebConfig -> - m MaxHealth -pendingTxsHealthCheck cfg = do - n <- blockStorePendingTxs cfg.store.block - return - MaxHealth - { max = fromIntegral cfg.maxPendingTxs, - count = fromIntegral n - } - --- | Online peers and the minimum required. -peerHealthCheck :: - (MonadUnliftIO m, StoreReadBase m) => - WebConfig -> - m CountHealth -peerHealthCheck cfg = do - count <- fromIntegral . length <$> liftIO (getPeers cfg.store.peerMgr) - return CountHealth {min = fromIntegral cfg.minPeers, count} - --- | Run every health check. -healthCheck :: - (MonadUnliftIO m, StoreReadBase m) => WebConfig -> m HealthCheck -healthCheck cfg = do - blocks <- blockHealthCheck cfg - lastBlock <- lastBlockHealthCheck cfg.store.chain cfg.limits - lastTx <- lastTxHealthCheck cfg - pendingTxs <- pendingTxsHealthCheck cfg - peers <- peerHealthCheck cfg - time <- round <$> liftIO getPOSIXTime - return - HealthCheck - { network = cfg.store.net.name, - version = cfg.version, - .. - } - --- | Handler for @GET \/dbstats@: RocksDB memory use and statistics, as text. -scottyDbStats :: (MonadUnliftIO m) => ActionT m () -scottyDbStats = - withMetrics (.db) $ do - setHeaders - db <- askl (.config.store.db.db) - memory <- liftIO (memoryReport db) - statsM <- liftIO (getProperty db Stats) - S.text . cs $ memory <> maybe "Could not get stats" cs statsM - ------------------------ --- Parameter Parsing -- ------------------------ - --- | Returns @Nothing@ if the parameter is not supplied. Raises an exception on --- parse failure. -paramOptional :: forall a m. (Param a, MonadUnliftIO m) => ActionT m (Maybe a) -paramOptional = do - net <- askl (.config.store.net) - ctx <- askl (.config.store.ctx) - fmap Just (param label) `rescue` return Nothing >>= \case - Nothing -> return Nothing -- Parameter was not supplied - Just ts -> maybe (raise err) (return . Just) (parseParam net ctx ts) - where - label = proxyLabel (Proxy :: Proxy a) - err = UserError $ "Unable to parse param " <> T.unpack label - --- | Raises an exception if the parameter is not supplied -paramRequired :: forall a m. (Param a, MonadUnliftIO m) => ActionT m a -paramRequired = maybe (raise err) return =<< paramOptional - where - label = T.unpack (proxyLabel (Proxy :: Proxy a)) - err = UserError $ "Param " <> label <> " not defined" - --- | Returns the default value of a parameter if it is not supplied. Raises an --- exception on parse failure. -paramDef :: (Default a, Param a, MonadUnliftIO m) => ActionT m a -paramDef = fromMaybe def <$> paramOptional - --- | Does not raise exceptions. Will call @Scotty.next@ if the parameter is --- not supplied or if parsing fails. -paramCapture :: forall a m. (Param a, MonadUnliftIO m) => ActionT m a -paramCapture = do - net <- askl (.config.store.net) - ctx <- askl (.config.store.ctx) - p <- S.captureParam label `rescue` S.next - maybe S.next return (parseParam net ctx p) - where - label = proxyLabel (Proxy :: Proxy a) - --- | Read the transaction that a request carries in its body. -parseTxBody :: (MonadUnliftIO m) => ActionT m Tx -parseTxBody = do - net <- askl (.config.store.net) - b <- L.toStrict <$> S.body - case decodeTxBody net b of - Left _ -> raise $ UserError "Failed to parse request body" - Right tx -> return tx - --- | Read a transaction from a request body. The body is the transaction in --- hex or as raw bytes. White space in the hex is ignored. --- --- The body must hold one transaction and nothing else. Bytes after the --- transaction are refused, as Bitcoin Core does for a raw transaction. --- --- The transaction must be in the format that peers of the network read. A --- network without SegWit, such as Bitcoin Cash, has the format without --- witness only. Its nodes would not read the SegWit format, so the store --- does not take it either. -decodeTxBody :: Network -> C.ByteString -> Either String Tx -decodeTxBody net body = fromHex <> fromBytes body - where - fromBytes = runGetS $ do - tx <- getNetworkTx net - done <- isEmpty - unless done $ fail "Trailing bytes after transaction" - return tx - fromHex = - case parseBase16 (C.filter (not . isSpace) body) of - Right b16 -> fromBytes (decodeBase16 b16) - Left e -> Left (cs e) - --- | Offset in the @offset@ parameter. Responds with an error if above the maximum. -parseOffset :: (MonadUnliftIO m) => ActionT m OffsetParam -parseOffset = do - res@(OffsetParam o) <- paramDef - limits <- askl (.config.limits) - when (limits.maxOffset > 0 && fromIntegral o > limits.maxOffset) $ - raise . UserError $ - "offset exceeded: " <> show o <> " > " <> show limits.maxOffset - return res - --- | Turn a start parameter into a position: a transaction, the block of a block --- hash, a height, or the last block at or before a time. -parseStart :: - (MonadUnliftIO m) => - Maybe StartParam -> - ActionT m (Maybe Start) -parseStart Nothing = return Nothing -parseStart (Just s) = - runMaybeT $ - case s of - StartParamHash {hash = h} -> start_tx h <|> start_block h - StartParamHeight {height = h} -> start_height h - StartParamTime {time = q} -> start_time q - where - start_height h = return $ AtBlock $ fromIntegral h - start_block h = do - b <- MaybeT $ getBlock (H.BlockHash h) - return $ AtBlock b.height - start_tx h = do - _ <- MaybeT $ getTxData (TxHash h) - return $ AtTx (TxHash h) - start_time q = do - ch <- lift $ askl (.config.store.chain) - b <- MaybeT $ blockAtOrBefore ch q - return $ AtBlock b.height - --- | Limit, offset and start in the parameters of a request. -parseLimits :: (MonadUnliftIO m) => ActionT m LimitsParam -parseLimits = LimitsParam <$> paramOptional <*> parseOffset <*> paramOptional - --- | Pagination of a query from request parameters, within the limits for full or short items. -paramToLimits :: - (MonadUnliftIO m) => - Bool -> - LimitsParam -> - ActionT m Limits -paramToLimits full (LimitsParam limitM o startM) = do - wl <- askl (.config.limits) - Limits (validateLimit wl full limitM) (fromIntegral o) <$> parseStart startM - --- | Limit of a query: the requested one or the default, but no more than the maximum. -validateLimit :: WebLimits -> Bool -> Maybe LimitParam -> Word32 -validateLimit wl full limitM = - f m $ maybe d (fromIntegral . (.get)) limitM - where - m - | full && wl.maxFullItemCount > 0 = wl.maxFullItemCount - | otherwise = wl.maxItemCount - d = wl.defItemCount - f a 0 = a - f 0 b = b - f a b = min a b - ---------------- --- Utilities -- ---------------- - --- | Run a query against the database, through the cache if there is one. -runInWebReader :: - (MonadIO m) => - CacheT (DatabaseReaderT m) a -> - ReaderT WebState m a -runInWebReader f = do - bdb <- asks (.config.store.db) - mc <- asks (.config.store.cache) - lift $ runReaderT (withCache mc f) bdb - --- | Run queries without the cache if the flag is 'True'. -runNoCache :: - (MonadIO m) => - Bool -> - ReaderT WebState m a -> - ReaderT WebState m a -runNoCache False = id -runNoCache True = local $ \s -> - s {config = s.config {store = s.config.store {cache = Nothing}}} - --- | Middleware that logs every request with its response status: errors at error level, others at debug level. -logIt :: Logger -> Middleware -logIt logger app req respond = - app req $ \res -> do - let s = responseStatus res - msg = fmtReq req <> ": " <> fmtStatus s - if statusIsSuccessful s - then logDebug logger msg - else logError logger msg - respond res - --- | Describe a request for logs. -fmtReq :: Request -> Text -fmtReq req = - let m = requestMethod req - v = httpVersion req - p = rawPathInfo req - q = rawQueryString req - in T.decodeUtf8 (m <> " " <> p <> q <> " " <> cs (show v)) - --- | Describe a response status for logs. -fmtStatus :: Status -> Text -fmtStatus s = cs (show (statusCode s)) <> " " <> cs (statusMessage s) - --- | Run a handler, or another if the first one fails. -rescue :: - (MonadUnliftIO m) => - S.ActionT m a -> - S.ActionT m a -> - S.ActionT m a -x `rescue` y = x `S.catch` \(_ :: S.ScottyException) -> y - --- | Read a request parameter from the path, query string or form. -param :: - (MonadUnliftIO m, S.Parsable a) => - Text -> - S.ActionT m a -param t = S.queryParam t `rescue` S.formParam t - --- | Read a field of the environment from a monad transformer. -askl :: (MonadTrans t, MonadReader r m) => (r -> a) -> t m a -askl f = lift (asks f) +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wno-deprecations #-} + +-- | +-- Module : Haskoin.Store.Web +-- Copyright : (c) Haskoin Developers +-- License : MIT +-- Maintainer : jprupp@protonmail.ch +-- Stability : experimental +-- Portability : POSIX +-- +-- REST API server of Haskoin Store, running directly on WAI and Warp. +-- +-- 'runWeb' serves the endpoints described in "Haskoin.Store.WebCommon" and a +-- set of endpoints compatible with the Blockchain.info API under +-- @\/blockchain\/@. Responses are JSON by default, pretty-printed with +-- @?pretty=true@, or binary if the request has the header +-- @Accept: application\/octet-stream@. New blocks and mempool transactions are +-- streamed at @\/events@, as lines of JSON or over a WebSocket. +-- +-- Limits on the size of responses are set with 'WebLimits'. Errors are +-- returned as JSON with an HTTP status that depends on the 'Except'. +-- = Design of the API +-- +-- * __Two encodings of the same data.__ JSON is easy to use from anywhere. The +-- binary encoding is several times smaller and faster to produce and parse, and +-- is what the Haskell client uses. +-- +-- * __Limits protect the server.__ A single request for every transaction of a +-- busy address could take minutes and gigabytes. 'WebLimits' caps list sizes +-- and offsets, and lower caps apply to full transactions, which are much larger +-- than references. +-- +-- * __Health is measured, not assumed.__ The store reports itself unhealthy when +-- it lags behind the network, stops receiving blocks or transactions, has too +-- few peers or a backlog of transactions. Load balancers can route around an +-- instance that is still syncing or has lost its peers. +-- +-- * __Slow event clients are dropped.__ Each @\/events@ client gets a bounded +-- queue. A client that falls too far behind is disconnected rather than allowed +-- to make the server buffer events without limit. +-- +-- * __Compatibility endpoints ease migration.__ The @\/blockchain\/@ endpoints +-- follow the Blockchain.info API so that existing wallets can switch to a +-- self-hosted server with few changes. +-- +-- * __Handlers are plain functions.__ A handler takes the 'WebState' and +-- the request ('Req'), and returns a response in 'IO'. The state holds the +-- queries to answer with in 'query' ('webQuery': the database, with the +-- cache in front of the queries about xpubs); @nocache=true@ is the same +-- handler given a state whose queries read only the database ('cacheOr'). +-- The state is made for each request, around one view of the database, +-- so that everything a request reads is of one moment; a store that is a +-- member of a fleet takes the view at the block that its fleet answers +-- from, with the mempool that the fleet shares on top, and has the +-- fleet's cache of xpubs in front of the queries about them +-- ("Haskoin.Store.Fleet.Member"). +-- Routes, parameters and the passing of a request to the next route are +-- in "Haskoin.Store.Web.Router", a few dozen lines over WAI. A handler +-- stops early by throwing an 'Except', which becomes the response +-- ('guarded'). There is no web framework and no monad transformer: a +-- framework runs every handler in a stack of its own, and a reader monad +-- in it would hide the state. +module Haskoin.Store.Web + ( -- * Web + WebConfig (..), + Except (..), + WebLimits (..), + runWeb, + runWebSocket, + + -- * Request parsing + decodeTxBody, + acceptsBinary, + ) +where + +import Conduit + ( ConduitT, + await, + concatMapC, + concatMapMC, + dropC, + dropWhileC, + headC, + lengthC, + mapC, + runConduit, + sinkList, + takeC, + takeWhileC, + yield, + (.|), + ) +import Control.Applicative ((<|>)) +import Control.Lens ((.~), (^.)) +import Control.Monad + ( filterM, + forM_, + forever, + guard, + join, + unless, + void, + when, + (<=<), + ) +import Control.Monad.Trans (lift) +import Data.Aeson + ( Encoding, + ToJSON (..), + Value, + ) +import Data.Aeson qualified as A +import Data.Aeson.Encode.Pretty + ( Config (..), + defConfig, + encodePretty', + ) +import Data.Aeson.Encoding + ( encodingToLazyByteString, + list, + ) +import Data.Aeson.Types (parseMaybe) +import Data.ByteString.Base16 (decodeBase16, parseBase16) +import Data.ByteString.Builder (lazyByteString) +import Data.ByteString.Char8 qualified as C +import Data.ByteString.Lazy qualified as L +import Data.Bytes.Get +import Data.Bytes.Put +import Data.Bytes.Serial +import Data.Char (isSpace) +import Data.Default (Default (..)) +import Data.Function ((&)) +import Data.HashMap.Strict (HashMap) +import Data.HashMap.Strict qualified as HashMap +import Data.HashSet (HashSet) +import Data.HashSet qualified as HashSet +import Data.Int (Int64) +import Data.List (nub) +import Data.Maybe + ( catMaybes, + fromJust, + fromMaybe, + isJust, + listToMaybe, + mapMaybe, + maybeToList, + ) +import Data.Proxy (Proxy (..)) +import Data.Serialize (Serialize, decode, encode) +import Data.String (fromString) +import Data.String.Conversions (cs) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Encoding qualified as T +import Data.Text.Lazy qualified as TL +import Data.Text.Lazy.Encoding qualified as TL +import Data.Time.Clock.POSIX (getPOSIXTime) +import Data.Word (Word32, Word64) +import Database.RocksDB + ( Property (..), + getProperty, + ) +import Haskoin.Address +import Haskoin.Block qualified as H +import Haskoin.Crypto.Keys +import Haskoin.Network +import Haskoin.Node + ( Chain, + Logger, + OnlinePeer (..), + PeerMgr, + chainGetAncestor, + chainGetBest, + getPeers, + logDebug, + logError, + sendMessage, + withSource, + ) +import Haskoin.Script +import Haskoin.Store.BlockStore +import Haskoin.Store.Cache +import Haskoin.Store.Common hiding + ( blockAtOrAfter, + blockAtOrAfterMTP, + blockAtOrBefore, + getActiveBlock, + getActiveTxData, + getDefaultBalance, + getNumTransaction, + getTransaction, + getTransactions, + ) +import Haskoin.Store.Common qualified as C +import Haskoin.Store.Data +import Haskoin.Store.Database.Query qualified as Q +import Haskoin.Store.Database.Query.Layered qualified as L +import Haskoin.Store.Database.Reader +import Haskoin.Store.Fleet.Member + ( Member (..), + TipMoved (..), + answeringCached, + memberAlive, + memberEvents, + memberTip, + ) +import Haskoin.Store.Fleet.Redis (FleetEvent (..)) +import Haskoin.Store.Manager +import Haskoin.Store.Web.Docs (swaggerPage, swaggerYaml) +import Haskoin.Store.Web.Events +import Haskoin.Store.Web.Router hiding (header) +import Haskoin.Store.Web.Router qualified as Router +import Haskoin.Store.WebCommon +import Haskoin.Transaction +import Haskoin.Util +import NQE + ( subscribe, + unsubscribe, + ) +import Network.HTTP.Types + ( Status (..), + hContentType, + methodGet, + methodPost, + parseQuery, + renderStdMethod, + status200, + status203, + status204, + status400, + status404, + status409, + status413, + status500, + status503, + statusIsClientError, + statusIsServerError, + statusIsSuccessful, + ) +import Network.Socket (Socket) +import Network.Wai + ( Application, + Middleware, + Request (..), + Response, + mapResponseHeaders, + modifyResponse, + responseLBS, + responseStatus, + responseStream, + ) +import Network.Wai.Handler.Warp + ( defaultSettings, + runSettings, + runSettingsSocket, + setHost, + setPort, + ) +import Network.Wai.Handler.WarpTLS (runTLS, runTLSSocket, tlsSettings) +import Network.Wai.Handler.WebSockets (websocketsOr) +import Network.Wai.Middleware.Autohead (autohead) +import Network.Wai.Middleware.Gzip (gzip) +import Network.Wai.Middleware.Gzip qualified as Gzip +import Network.WebSockets + ( acceptRequest, + defaultConnectionOptions, + pendingRequest, + rejectRequestWith, + requestPath, + sendBinaryData, + sendTextData, + ) +import Network.WebSockets qualified as WebSockets +import Network.WebSockets.Connection.PingPong + ( PingPongOptions (..), + defaultPingPongOptions, + withPingPong, + ) +import Network.Wreq qualified as Wreq +import Network.Wreq.Session as Wreq (Session) +import Network.Wreq.Session qualified as Wreq.Session +import Numeric.Natural (Natural) +import System.Metrics.StatsD +import Text.Read (readMaybe) +import UnliftIO + ( TVar, + async, + atomically, + bracket, + bracket_, + catch, + catchAny, + fromException, + handleAny, + link, + newIORef, + newTQueueIO, + newTVarIO, + race_, + readIORef, + readTQueue, + readTVarIO, + stateTVar, + throwIO, + timeout, + try, + withAsync, + writeIORef, + writeTQueue, + writeTVar, + ) +import UnliftIO.Concurrent (threadDelay) + +-- | Limits of the API. A value of @0@ means no limit. +data WebLimits = WebLimits + { -- | maximum number of items in a list response + maxItemCount :: !Word32, + -- | maximum number of full transactions in a list response + maxFullItemCount :: !Word32, + -- | maximum offset of a paged query + maxOffset :: !Word32, + -- | number of items in a list response when no limit is given + defItemCount :: !Word32, + -- | consecutive unused addresses after which xpub derivation stops + xpubGap :: !Word32, + -- | unused addresses to look at for an xpub with no transactions + xpubGapInit :: !Word32, + -- | seconds without a new transaction before the store is reported + -- unhealthy + txTimeout :: !Word64, + -- | seconds without a new block before the store is reported unhealthy + blockTimeout :: !Word64 + } + deriving (Eq, Show) + +-- | 200000 items, 5000 full transactions, offset up to 50000, 100 items by +-- default, xpub gaps of 32 and 20, transaction timeout of 30 minutes and +-- block timeout of four hours. +instance Default WebLimits where + def = + WebLimits + { maxItemCount = 200000, + maxFullItemCount = 5000, + maxOffset = 50000, + defItemCount = 100, + xpubGap = 32, + xpubGapInit = 20, + txTimeout = 3600 `div` 2, + blockTimeout = 4 * 3600 + } + +-- | Configuration of the web server. +data WebConfig = WebConfig + { -- | address to listen on, such as @*@ for all + host :: !String, + -- | port to listen on + port :: !Int, + -- | running store to serve + store :: !Store, + -- | blocks that the database may lag behind the headers before the store + -- is reported unhealthy + maxLaggingBlocks :: !Int, + -- | transactions that may be waiting to be imported before the store is + -- reported unhealthy + maxPendingTxs :: !Int, + -- | fewest peers before the store is reported unhealthy + minPeers :: !Int, + -- | limits of the API + limits :: !WebLimits, + -- | version reported by the health check + version :: !String, + -- | the mempool is not indexed, so do not report it in health checks + noMempool :: !Bool, + -- | StatsD client, if metrics are enabled + stats :: !(Maybe Stats), + -- | microseconds between updates of the price ticker + tickerRefresh :: !Int, + -- | URL of the price ticker service + tickerURL :: !String, + -- | URL of the historical price service + priceHistoryURL :: !String, + -- | disable the xpub endpoints + noXPub :: !Bool, + -- | disable the Blockchain.info compatible endpoints + noBlockchainInfo :: !Bool, + -- | seconds between health checks + healthCheckInterval :: !Int, + -- | a certificate and its private key, in files in PEM format, to + -- serve HTTPS instead of HTTP; 'Nothing' for HTTP, which is the + -- default + tls :: !(Maybe (FilePath, FilePath)), + -- | log messages here + logger :: !Logger + } + +-- | State shared by all request handlers. +data WebState = WebState + { -- | configuration + config :: !WebConfig, + -- | latest prices by currency code + ticker :: !(TVar (HashMap Text BinfoTicker)), + -- | StatsD metrics, if enabled + metrics :: !(Maybe WebMetrics), + -- | HTTP session for price requests + session :: !Wreq.Session, + -- | result of the latest health check + health :: !(TVar HealthCheck), + -- | the queries to answer with, the cache included ('webQuery'): those + -- of one view of the database, taken for the request + query :: !StoreRead, + -- | the same queries without the cache, on the same view + direct :: !StoreRead, + -- | whether Redis answered the last time it was asked; always 'True' + -- for a store without a cache + cacheUp :: !(TVar Bool), + -- | the events that the clients of @\/events@ read ('feedEvents') + eventLog :: !EventLog + } + +-- | StatsD metrics of the web server: a timing for each kind of request, +-- under @web.\@, error counters and a gauge of connected event +-- clients. +data WebMetrics = WebMetrics + { -- Addresses + addressTx :: !StatTiming, + addressTxFull :: !StatTiming, + addressBalance :: !StatTiming, + addressUnspent :: !StatTiming, + xpub :: !StatTiming, + xpubDelete :: !StatTiming, + xpubTxFull :: !StatTiming, + xpubTx :: !StatTiming, + xpubBalance :: !StatTiming, + xpubUnspent :: !StatTiming, + -- Transactions + tx :: !StatTiming, + txRaw :: !StatTiming, + txAfter :: !StatTiming, + txBlock :: !StatTiming, + txBlockRaw :: !StatTiming, + txPost :: !StatTiming, + mempool :: !StatTiming, + -- Blocks + block :: !StatTiming, + blockRaw :: !StatTiming, + -- Blockchain + binfoMultiaddr :: !StatTiming, + binfoBalance :: !StatTiming, + binfoAddressRaw :: !StatTiming, + binfoUnspent :: !StatTiming, + binfoTxRaw :: !StatTiming, + binfoBlock :: !StatTiming, + binfoBlockHeight :: !StatTiming, + binfoBlockLatest :: !StatTiming, + binfoBlockRaw :: !StatTiming, + binfoMempool :: !StatTiming, + binfoExportHistory :: !StatTiming, + -- Blockchain /q endpoints + binfoQaddresstohash :: !StatTiming, + binfoQhashtoaddress :: !StatTiming, + binfoQaddrpubkey :: !StatTiming, + binfoQpubkeyaddr :: !StatTiming, + binfoQhashpubkey :: !StatTiming, + binfoQgetblockcount :: !StatTiming, + binfoQlatesthash :: !StatTiming, + binfoQbcperblock :: !StatTiming, + binfoQtxtotalbtcoutput :: !StatTiming, + binfoQtxtotalbtcinput :: !StatTiming, + binfoQtxfee :: !StatTiming, + binfoQtxresult :: !StatTiming, + binfoQgetreceivedbyaddress :: !StatTiming, + binfoQgetsentbyaddress :: !StatTiming, + binfoQaddressbalance :: !StatTiming, + binfoQaddressfirstseen :: !StatTiming, + -- Errors + serverErrors :: StatCounter, + clientErrors :: StatCounter, + -- Others + health :: !StatTiming, + peers :: !StatTiming, + db :: !StatTiming, + events :: !StatGauge + } + +-- | Register the web server metrics with a StatsD client. +createMetrics :: Stats -> IO WebMetrics +createMetrics s = do + -- Addresses + addressTx <- d "address_transactions" + addressTxFull <- d "address_transactions_full" + addressBalance <- d "address_balance" + addressUnspent <- d "address_unspent" + xpub <- d "xpub" + xpubDelete <- d "xpub_delete" + xpubTxFull <- d "xpub_transactions_full" + xpubTx <- d "xpub_transactions" + xpubBalance <- d "xpub_balances" + xpubUnspent <- d "xpub_unspent" + + -- Transactions + tx <- d "transaction" + txRaw <- d "transaction_raw" + txAfter <- d "transaction_after" + txPost <- d "transaction_post" + txBlock <- d "transactions_block" + txBlockRaw <- d "transactions_block_raw" + mempool <- d "mempool" + + -- Blocks + block <- d "block" + blockRaw <- d "block_raw" + + -- Blockchain + binfoMultiaddr <- d "blockchain_multiaddr" + binfoBalance <- d "blockchain_balance" + binfoAddressRaw <- d "blockchain_rawaddr" + binfoUnspent <- d "blockchain_unspent" + binfoTxRaw <- d "blockchain_rawtx" + binfoBlock <- d "blockchain_blocks" + binfoBlockHeight <- d "blockchain_block_height" + binfoBlockLatest <- d "blockchain_latestblock" + binfoBlockRaw <- d "blockchain_rawblock" + binfoMempool <- d "blockchain_mempool" + binfoExportHistory <- d "blockchain_export_history" + + -- Blockchain /q endpoints + binfoQaddresstohash <- d "blockchain_q_addresstohash" + binfoQhashtoaddress <- d "blockchain_q_hashtoaddress" + binfoQaddrpubkey <- d "blockckhain_q_addrpubkey" + binfoQpubkeyaddr <- d "blockchain_q_pubkeyaddr" + binfoQhashpubkey <- d "blockchain_q_hashpubkey" + binfoQgetblockcount <- d "blockchain_q_getblockcount" + binfoQlatesthash <- d "blockchain_q_latesthash" + binfoQbcperblock <- d "blockchain_q_bcperblock" + binfoQtxtotalbtcoutput <- d "blockchain_q_txtotalbtcoutput" + binfoQtxtotalbtcinput <- d "blockchain_q_txtotalbtcinput" + binfoQtxfee <- d "blockchain_q_txfee" + binfoQtxresult <- d "blockchain_q_txresult" + binfoQgetreceivedbyaddress <- d "blockchain_q_getreceivedbyaddress" + binfoQgetsentbyaddress <- d "blockchain_q_getsentbyaddress" + binfoQaddressbalance <- d "blockchain_q_addressbalance" + binfoQaddressfirstseen <- d "blockchain_q_addressfirstseen" + + -- Errors + serverErrors <- c "server_errors" + clientErrors <- c "client_errors" + + -- Others + health <- d "health" + peers <- d "peers" + db <- d "dbstats" + + events <- g "events_connected" + return WebMetrics {..} + where + d x = newStatTiming s ("web." <> x) 10 + g x = newStatGauge s ("web." <> x) 0 + c x = newStatCounter s ("web." <> x) 10 + +-- | Increase a gauge while an action runs. +withGaugeIO :: StatGauge -> IO a -> IO a +withGaugeIO g = bracket_ (incrementGauge g 1) (decrementGauge g 1) + +-- | Increase a gauge of the web metrics while a handler runs. +withGaugeIncrease :: + WebState -> + (WebMetrics -> StatGauge) -> + IO a -> + IO a +withGaugeIncrease st gf go = + case st.metrics of + Nothing -> go + Just m -> withGaugeIO (gf m) go + +-- | Record how long a handler takes in a timing of the web metrics. +withMetrics :: + WebState -> + (WebMetrics -> StatTiming) -> + IO a -> + IO a +withMetrics st df go = + case st.metrics of + Nothing -> go + Just m -> bracket time (stop m) (const go) + where + time = round . (* 1000) <$> getPOSIXTime + stop m t1 = do + t2 <- time + addTiming (df m) (t2 - t1) + +-- | Encoding of a response. +data SerialAs + = -- | binary, for @Accept: application\/octet-stream@ + SerialAsBinary + | -- | compact JSON + SerialAsJSON + | -- | indented JSON, for @?pretty=true@ + SerialAsPrettyJSON + deriving (Eq, Show) + +------------------- +-- Path Handlers -- +------------------- + +-- | Run the web server forever on the host and port of the configuration. +-- Also starts a thread that updates prices, unless the Blockchain.info +-- endpoints are disabled, and a thread that runs health checks. +-- +-- = HTTPS +-- +-- With a certificate and a key in 'tls', the server speaks HTTPS on that +-- port, and nothing else: TLS 1.2 and 1.3, and HTTP\/2 for clients that +-- ask for it. It is off by default. A public service usually sits behind +-- a proxy that has the certificate, limits requests and spreads them over +-- servers; this is for a server by itself, and for links between machines +-- that should not be in the clear. The files are read when the server +-- starts, so a renewed certificate takes a restart. +runWeb :: WebConfig -> IO () +runWeb config = serveWeb config $ case config.tls of + Nothing -> runSettings settings + Just (certificate, key) -> runTLS (tlsSettings certificate key) settings + where + settings = setPort config.port . setHost (fromString config.host) $ defaultSettings + +-- | Like 'runWeb', on a socket that already listens; the host and port of the +-- configuration are ignored. Binding port 0 and passing the socket gives a +-- free port with no window in which another program can take it, which +-- finding a free port first and binding it later has. +runWebSocket :: WebConfig -> Socket -> IO () +runWebSocket config sock = serveWeb config $ case config.tls of + Nothing -> runSettingsSocket defaultSettings sock + Just (certificate, key) -> runTLSSocket (tlsSettings certificate key) defaultSettings sock + +-- | Run the web server with a function of Warp that serves an application. +-- The application is the router ("Haskoin.Store.Web.Router") with the +-- routes of 'handlePaths', behind the middleware for WebSocket events, for +-- logs and for the header that lets any origin make requests. +serveWeb :: WebConfig -> (Application -> IO ()) -> IO () +serveWeb config serve = do + ticker <- newTVarIO HashMap.empty + metrics <- mapM createMetrics config.stats + session <- Wreq.Session.newAPISession + health <- runHealthCheck >>= newTVarIO + cacheUp <- cacheCheck >>= newTVarIO + eventLog <- newEventLog + let db = config.store.db + stateOf q = WebState {query = webQuery config.store cacheUp q, direct = q, ..} + routesOf s = map (guarded s) (concatMap withPost (handlePaths s config)) + -- outside of a request, each query has a view of its own; a request + -- has one view for all that it reads, which is let go when its + -- response is sent + st = stateOf (L.standaloneRead db) + local answer = L.withView db (answer . routesOf . stateOf . L.layeredRead) + scoped answer = case config.store.fleet of + Nothing -> local answer + Just member -> + readTVarIO cacheUp >>= \case + True -> shared member (3 :: Int) False answer + -- without Redis there is no fleet to answer with + False -> local answer + -- as a member of a fleet: from the view at the fleet tip, with the + -- pool that the fleet shares on top. The tip is taken to be the one + -- that the member read at its last turn, which saves asking Redis + -- for it: the first read of the pool checks it, and a request that + -- reads nothing from the pool checks it when its handler is done. If + -- it is not the tip any more, the request is answered again, from the + -- tip that Redis has. + shared member tries fresh answer = do + known <- if fresh then return Nothing else fmap encode <$> readTVarIO member.tip + asked <- case known of + Just tip -> return (Just (Just tip)) + Nothing -> timeout 2000000 (memberTip member) `catchAny` \_ -> return Nothing + case asked of + Nothing -> atomically (writeTVar cacheUp False) >> local answer + -- no store has reported yet + Just Nothing -> local answer + Just (Just tip) -> do + handled <- newIORef False + let marked confirm r = r {handler = \req -> r.handler req <* confirm <* writeIORef handled True} :: Route + -- extended public keys through the fleet's cache of + -- them, unless a request asks for the database + inFleet plain cached confirm = + answer (map (marked confirm) (routesOf WebState {query = cached, direct = plain, ..})) + try (answeringCached member tip inFleet) >>= \case + Right (Just sent) -> return sent + Right Nothing + -- a tip from the member's last turn of which there is no + -- view may not be the tip any more + | not fresh && tries > 0 -> shared member (tries - 1) True answer + | otherwise -> behind answer + Left TipMoved -> + -- the tip moved while the handler was reading: answer + -- again from the new one, unless the response is on its way + readIORef handled >>= \case + True -> throwIO TipMoved + False + | tries > 0 -> shared member (tries - 1) True answer + | otherwise -> behind answer + behind answer = answer [r {handler = behindResponse st} :: Route | r <- routes] + -- the stream of events never ends, and reads nothing from the + -- database: answered like the rest it would hold a view, and the + -- data under it, for as long as its client listens + app request + | pathInfo request == ["events"] = routerScoped routes ($ routes) notFound request + | otherwise = routerScoped routes scoped notFound request + routes = routesOf st + notFound req NoRoute = errorResponse st req ThingNotFound + notFound req (Unknown ks) = + errorResponse st req . UserError $ + "Unknown parameter: " <> T.unpack (T.intercalate ", " ks) + withAsync (priceUpdater session ticker) $ \_a1 -> + withAsync (healthCheckLoop health cacheUp) $ \_a2 -> + withAsync (feedEvents st) $ \a3 -> + link a3 >> do + serve . webSocketEvents st . logIt config.logger . anyOrigin . preflight . autohead . compressed $ app + where + priceUpdater session = + unless config.noBlockchainInfo + . price + (withSource "Price" config.logger) + config.store.net + session + config.tickerURL + config.tickerRefresh + runHealthCheck = healthCheck config + cacheCheck = case (config.store.cache, config.store.fleet) of + (Just cache, _) -> cacheAlive cache + (_, Just member) -> memberAlive member + _ -> return True + healthCheckLoop v up = loopForever $ do + threadDelay (config.healthCheckInterval * 1000 * 1000) + h <- runHealthCheck + atomically (writeTVar v h) + -- a store whose checks fail stops taking its turns as a member of + -- its fleet, so that it does not hold the others back + forM_ config.store.fleet $ \member -> atomically (writeTVar member.healthy (isOK h)) + cacheCheck >>= atomically . writeTVar up + -- what a browser asks before a request from another site that is not + -- of the plainest kind: which methods and headers it may use. Without + -- an answer it does not send the request. + preflight inner req respond + | requestMethod req == "OPTIONS" = + respond $ + responseLBS + status204 + [ ("Allow", allowed), + ("Access-Control-Allow-Methods", allowed), + ("Access-Control-Allow-Headers", "Accept, Content-Type"), + ("Access-Control-Max-Age", "86400") + ] + "" + | otherwise = inner req respond + allowed = "GET, HEAD, POST, DELETE, OPTIONS" + -- answers are compressed for a client that says it reads gzip: JSON + -- shrinks several times over, and the binary format, which is mostly + -- hashes, by less. The events are a stream that has to leave as it is + -- written, and are left alone. + compressed inner req + | pathInfo req == ["events"] = inner req + | otherwise = gzip gzipSettings inner req + gzipSettings = + Gzip.defaultGzipSettings + { Gzip.gzipCheckMime = \m -> Gzip.defaultCheckMime m || "application/octet-stream" `C.isPrefixOf` m + } + -- any origin may ask, and what is answered depends on the format that + -- was asked for, which a cache between the client and the server has + -- to know: it must not give the JSON of one client to another that + -- asked for binary. The same goes for whether it is compressed, and + -- the two are said in one header. + anyOrigin = modifyResponse (mapResponseHeaders varied) + varied headers = + [("Access-Control-Allow-Origin", "*"), ("Vary", "Accept, Accept-Encoding")] + <> filter ((/= "Vary") . fst) headers + +-- | Answer the errors of the handler of a route: an 'Except' with its +-- status and JSON, any other error as a server error, after logging it. A +-- request passed on to the next route goes on. +guarded :: WebState -> Route -> Route +guarded st r = r {handler = \req -> r.handler req `catchAny` answer req} + where + answer req e + | Just Next <- fromException e = throwIO Next + | Just TipMoved <- fromException e = throwIO TipMoved + | Just x <- fromException e = errorResponse st req x + | otherwise = do + logError st.config.logger $ fmtReq req.wai <> ": " <> cs (show e) + errorResponse st req ServerError + +-- | What a store that is a member of a fleet answers when it has no view of +-- the block that the fleet answers from: 503, so that a load balancer sends +-- the request to another store. Any answer of its own could differ from +-- those of the other stores, which is what a fleet is there to prevent. +behindResponse :: WebState -> Req -> IO Response +behindResponse st req = errorResponse st req BehindFleet + +-- | The response to an error, counted in the metrics, in the format that +-- the request asked for. +-- +-- Errors were JSON whatever was asked, because 'Except' had no binary +-- encoding. A client that speaks binary had to carry a JSON decoder for +-- the one answer that it least expects. From haskoin-store-data 1.10 an +-- error has a binary encoding like everything else. +errorResponse :: WebState -> Req -> Except -> IO Response +errorResponse st req e = do + forM_ st.metrics $ \m -> + mapM_ (`incrementCounter` 1) $ + if + | statusIsClientError (errStatus e) -> Just m.clientErrors + | statusIsServerError (errStatus e) -> Just m.serverErrors + | otherwise -> Nothing + return $ + if wantsBinary req + then responseLBS (errStatus e) ((hContentType, "application/octet-stream") : again) (runPutL (serialize e)) + else responseLBS (errStatus e) ((hContentType, "application/json") : again) (A.encode e) + where + -- a server behind its fleet catches up within a block or is taken out + -- of rotation: a client or a load balancer that reads this header + -- tries again in a second, and elsewhere meanwhile + again = [("Retry-After", "1") | e == BehindFleet] + +-- | Historical prices of the coin of the network in a currency at several times. Returns an empty list on failure. +getRates :: + Logger -> + Network -> + Wreq.Session -> + String -> + Text -> + [Word64] -> + IO [BinfoRate] +getRates logger net session url currency times = do + handleAny err $ do + r <- + Wreq.asJSON + =<< Wreq.Session.postWith opts session url body + return $ r ^. Wreq.responseBody + where + err _ = do + logError logger "Could not get historic prices" + return [] + body = toJSON times + base = + Wreq.defaults + & Wreq.param "base" .~ [T.toUpper $ T.pack net.name] + opts = base & Wreq.param "quote" .~ [currency] + +-- | Update the prices of the coin of the network periodically, for BTC and BCH only. +price :: + Logger -> + Network -> + Wreq.Session -> + String -> + Int -> + TVar (HashMap Text BinfoTicker) -> + IO () +price logger net session url pget v = forM_ purl $ \u -> loopForever $ do + let err e = logError logger $ cs (show e) + handleAny err $ do + r <- Wreq.asJSON =<< Wreq.Session.get session u + atomically . writeTVar v $ r ^. Wreq.responseBody + threadDelay pget + where + purl = case code of + Nothing -> Nothing + Just x -> Just (url <> "?base=" <> x) + where + code + | net == btc = Just "btc" + | net == bch = Just "bch" + | otherwise = Nothing + +-- | Stop handling the request, and answer with an error ('guarded'). +raise :: WebState -> Except -> IO a +raise _ = throwIO + +-- | HTTP status of an error. +errStatus :: Except -> Status +errStatus ThingNotFound = status404 +errStatus BadRequest = status400 +errStatus UserError {} = status400 +errStatus StringError {} = status400 +errStatus ServerError = status500 +errStatus TxIndexConflict {} = status409 +errStatus ServerTimeout = status500 +errStatus RequestTooLarge = status413 +errStatus BehindFleet = status503 + +-- | A route, and with it the same route under @POST@ if it takes a list in +-- a parameter: addresses, blocks, heights or transactions. +-- +-- A list in the query string has to fit in a URL, and proxies cut those +-- off at a few thousand characters: some hundred addresses. The router +-- reads the parameters of a form in the body as it reads those of the +-- query string, so under @POST@ the same parameters go in the body, with +-- @Content-Type: application\/x-www-form-urlencoded@, and have no such +-- limit. @\/transactions@ is left out: @POST@ there publishes a +-- transaction. +withPost :: Route -> [Route] +withPost r + | r.method == methodGet && takesList && r.pattern /= [Left "transactions"] = [r, r {method = methodPost}] + | otherwise = [r] + where + takesList = any (`elem` r.accepts) ["addresses", "blocks", "heights", "txids"] + +-- | The parameters of @\/events@ that say what a client hears about from +-- the start ('eventsOpen'). +eventParams :: [Text] +eventParams = ["quiet", "addresses", "xpub", "derive", "filter", "functions", "tweak", "flags"] + +-- | The routes of every endpoint, except those disabled in the configuration. +handlePaths :: WebState -> WebConfig -> [Route] +handlePaths st cfg = + [ marshalled ["notx"] (\r -> GetBlockBest <$> dflt r) (handleBlockBest st), + marshalledList ["notx"] (\r -> GetBlockHeight <$> cap r <*> dflt r) (handleBlockHeight st), + marshalled ["notx"] (\r -> GetBlockTime <$> cap r <*> dflt r) (handleBlockTime st), + marshalled ["notx"] (\r -> GetBlockMTP <$> cap r <*> dflt r) (handleBlockMTP st), + marshalled ["notx"] (\r -> GetBlock <$> cap r <*> dflt r) (handleBlock st), + marshalled [] (\r -> GetTx <$> cap r) (handleTx st), + plain [] (\r -> GetTxRaw <$> cap r) (handleTxRaw st), + plain [] (\r -> PostTx <$> parseTxBody st r) (handlePostTx st), + plainList limits (\r -> GetAddrTxs <$> cap r <*> lim r) (handleAddrTxs st), + marshalled [] (\r -> GetAddrBalance <$> cap r) (handleAddrBalance st), + marshalledList limits (\r -> GetAddrUnspent <$> cap r <*> lim r) (handleAddrUnspent st), + plainList [] (\_ -> return GetPeers) (handlePeers st), + pathHealth st, + plainList ["limit", "offset"] (\r -> GetMempool <$> opt r <*> off r) (handleMempool st), + marshalledList ["blocks", "notx"] (\r -> GetBlocks <$> need r <*> dflt r) (handleBlocks st), + plain [] (\r -> GetBlockRaw <$> cap r) (handleBlockRaw st), + plain [] (\_ -> return GetBlockBestRaw) (handleBlockBestRaw st), + marshalledList ["notx"] (\r -> GetBlockLatest <$> dflt r) (handleBlockLatest st), + marshalledList ["heights", "notx"] (\r -> GetBlockHeights <$> need r <*> dflt r) (handleBlockHeights st), + plain [] (\r -> GetBlockHeightRaw <$> cap r) (handleBlockHeightRaw st), + plain [] (\r -> GetBlockTimeRaw <$> cap r) (handleBlockTimeRaw st), + plain [] (\r -> GetBlockMTPRaw <$> cap r) (handleBlockMTPRaw st), + marshalledList ["txids"] (\r -> GetTxs <$> need r) (handleTxs st), + plain ["txids"] (\r -> GetTxsRaw <$> need r) (handleTxsRaw st), + marshalledList [] (\r -> GetTxsBlock <$> cap r) (handleTxsBlock st), + plain [] (\r -> GetTxsBlockRaw <$> cap r) (handleTxsBlockRaw st), + plain [] (\r -> GetTxAfter <$> cap r <*> cap r) (handleTxAfter st), + plainList ("addresses" : limits) (\r -> GetAddrsTxs <$> need r <*> lim r) (handleAddrsTxs st), + marshalledList limits (\r -> GetAddrTxsFull <$> cap r <*> lim r) (handleAddrTxsFull st), + marshalledList ("addresses" : limits) (\r -> GetAddrsTxsFull <$> need r <*> lim r) (handleAddrsTxsFull st), + marshalledList ["addresses"] (\r -> GetAddrsBalance <$> need r) (handleAddrsBalance st), + marshalledList ("addresses" : limits) (\r -> GetAddrsUnspent <$> need r <*> lim r) (handleAddrsUnspent st), + get "/events" ("pretty" : "after" : eventParams) (handleEvents st), + get "/dbstats" [] (handleDbStats st), + -- the reference of the API, as a page and as the file that it shows + get "/" [] (\_ -> file "text/html; charset=utf-8" swaggerPage), + get "/swagger.yaml" [] (\_ -> file "application/yaml" swaggerYaml) + ] + <> (if cfg.noXPub then [] else xpubRoutes) + <> (if cfg.noBlockchainInfo then [] else binfoRoutes) + where + file kind bytes = return (responseLBS status200 [(hContentType, kind)] (L.fromStrict bytes)) + net = cfg.store.net + -- the parameters that routes accept, beyond those of each route + limits = ["limit", "offset", "height"] + active = ["active", "activeP2SH", "activeBech32"] + -- the Blockchain.info endpoints accept format=json ('jsonOnly') + multiaddrParams = + ["format", "onlyShow", "n", "offset", "noCompact", "no_compact", "currency", "cashaddr", "txidindex", "filter"] + <> active + rawaddrParams = ["format", "derive", "limit", "offset", "txidindex"] + balanceParams = "format" : "cashaddr" : active + unspentParams = "format" : "limit" : "confirmations" : "txidindex" : active + historyParams = "format" : "start" : "end" : "currency" : active + -- the parameters of a request + cap, need :: (Param a) => Req -> IO a + cap = paramCapture st + need = paramRequired st + dflt :: (Default a, Param a) => Req -> IO a + dflt = paramDef st + opt :: (Param a) => Req -> IO (Maybe a) + opt = paramOptional st + lim = parseLimits st + off = parseOffset st + -- routes by how they encode their responses: in the JSON of the + -- network, as a list of those, or in plain JSON + marshalled :: + (ApiResource a b, MarshalJSON Network b) => [Text] -> (Req -> IO a) -> (a -> IO b) -> Route + marshalled ps p h = pathCompact st ps p h (marshalEncoding net) (marshalValue net) + marshalledList :: + (ApiResource a (SerialList b), MarshalJSON Network b) => [Text] -> (Req -> IO a) -> (a -> IO [b]) -> Route + marshalledList ps p h = + pathCompact + st + ps + p + (fmap SerialList . h) + (list (marshalEncoding net) . (.get)) + (toJSONList . map (marshalValue net) . (.get)) + plain :: (ApiResource a b, ToJSON b) => [Text] -> (Req -> IO a) -> (a -> IO b) -> Route + plain ps p h = pathCompact st ps p h toEncoding toJSON + plainList :: + (ApiResource a (SerialList b), ToJSON b) => [Text] -> (Req -> IO a) -> (a -> IO [b]) -> Route + plainList ps p h = plain ps p (fmap SerialList . h) + xpubRoutes = + [ plain ["derive", "nocache"] (\r -> GetXPub <$> cap r <*> dflt r <*> dflt r) (handleXPub st), + plainList + ("derive" : "nocache" : limits) + (\r -> GetXPubTxs <$> cap r <*> dflt r <*> lim r <*> dflt r) + (handleXPubTxs st), + marshalledList + ("derive" : "nocache" : limits) + (\r -> GetXPubTxsFull <$> cap r <*> dflt r <*> lim r <*> dflt r) + (handleXPubTxsFull st), + marshalledList + ["derive", "nocache"] + (\r -> GetXPubBalances <$> cap r <*> dflt r <*> dflt r) + (handleXPubBalances st), + marshalledList + ("derive" : "nocache" : limits) + (\r -> GetXPubUnspent <$> cap r <*> dflt r <*> lim r <*> dflt r) + (handleXPubUnspent st), + plain ["derive"] (\r -> DelCachedXPub <$> cap r <*> dflt r) (handleDelXPub st) + ] + binfoRoutes = + [ post "/blockchain/multiaddr" multiaddrParams (jsonOnly (handleMultiAddr st)), + get "/blockchain/multiaddr" multiaddrParams (jsonOnly (handleMultiAddr st)), + get "/blockchain/balance" balanceParams (jsonOnly (handleShortBal st)), + post "/blockchain/balance" balanceParams (jsonOnly (handleShortBal st)), + get "/blockchain/rawaddr/:addr" rawaddrParams (jsonOnly (handleRawAddr st)), + get "/blockchain/address/:addr" rawaddrParams (jsonOnly (handleRawAddr st)), + get "/blockchain/xpub/:addr" rawaddrParams (jsonOnly (handleRawAddr st)), + post "/blockchain/unspent" unspentParams (jsonOnly (handleBinfoUnspent st)), + get "/blockchain/unspent" unspentParams (jsonOnly (handleBinfoUnspent st)), + get "/blockchain/rawtx/:txid" ["format", "txidindex"] (handleBinfoTx st), + get "/blockchain/rawblock/:block" ["format", "txidindex"] (handleBinfoBlock st), + get "/blockchain/latestblock" ["format", "txidindex"] (jsonOnly (handleBinfoLatest st)), + get + "/blockchain/unconfirmed-transactions" + ["format", "limit", "offset", "txidindex"] + (jsonOnly (handleBinfoMempool st)), + get "/blockchain/block-height/:height" ["format", "txidindex"] (jsonOnly (handleBinfoBlockHeight st)), + get "/blockchain/blocks/:milliseconds" ["format"] (jsonOnly (handleBinfoBlocksDay st)), + get "/blockchain/export-history" historyParams (jsonOnly (handleBinfoHistory st)), + post "/blockchain/export-history" historyParams (jsonOnly (handleBinfoHistory st)), + get "/blockchain/q/addresstohash/:addr" [] (handleBinfoAddrToHash st), + get "/blockchain/q/hashtoaddress/:hash" [] (handleBinfoHashToAddr st), + get "/blockchain/q/addrpubkey/:pubkey" [] (handleBinfoAddrPubkey st), + get "/blockchain/q/pubkeyaddr/:addr" [] (handleBinfoPubKeyAddr st), + get "/blockchain/q/hashpubkey/:pubkey" [] (handleBinfoHashPubkey st), + get "/blockchain/q/getblockcount" [] (handleBinfoGetBlockCount st), + get "/blockchain/q/latesthash" [] (handleBinfoLatestHash st), + get "/blockchain/q/bcperblock" [] (handleBinfoSubsidy st), + get "/blockchain/q/txtotalbtcoutput/:txid" [] (handleBinfoTotalOut st), + get "/blockchain/q/txtotalbtcinput/:txid" [] (handleBinfoTotalInput st), + get "/blockchain/q/txfee/:txid" [] (handleBinfoTxFees st), + get "/blockchain/q/txresult/:txid/:addr" [] (handleBinfoTxResult st), + get "/blockchain/q/getreceivedbyaddress/:addr" [] (handleBinfoReceived st), + get "/blockchain/q/getsentbyaddress/:addr" [] (handleBinfoSent st), + get "/blockchain/q/addressbalance/:addr" [] (handleBinfoAddrBalance st), + get "/blockchain/q/addressfirstseen/:addr" [] (handleFirstSeen st) + ] + +-- | A handler of the Blockchain.info endpoints that answer in JSON only. They +-- accept @format=json@, which clients written for Blockchain.info often +-- send, and refuse any other format rather than answering in JSON anyway. +jsonOnly :: (Req -> IO Response) -> Req -> IO Response +jsonOnly h req = do + paramOr req json "format" () + h req + where + json "json" = Just () + json _ = Nothing + +-- | Register a handler for an API resource, with compact JSON by default. +pathCompact :: + (ApiResource a b) => + WebState -> + [Text] -> + (Req -> IO a) -> + (a -> IO b) -> + (b -> Encoding) -> + (b -> Value) -> + Route +pathCompact st ps parser action encJson encValue = + pathCommon st ps parser action (const status200) encJson encValue False + +-- | The route of an API resource: parse the request, run the handler, and +-- encode the response as JSON or binary, as the client asked. It accepts the +-- parameters given, and @pretty@. +pathCommon :: + (ApiResource a b) => + WebState -> + [Text] -> + (Req -> IO a) -> + (a -> IO b) -> + (b -> Status) -> + (b -> Encoding) -> + (b -> Value) -> + Bool -> + Route +pathCommon _ ps parser action status encJson encValue pretty = + route (renderStdMethod (resourceMethod proxy)) (capturePath proxy) ("pretty" : ps) $ \req -> do + proto <- serialAs req pretty + res <- action =<< parser req + return $ + responseLBS (status res) [(hContentType, serialType proto)] (protoSerial proto encJson encValue res) + where + toProxy :: (Req -> IO a) -> Proxy a + toProxy = const Proxy + proxy = toProxy parser + +-- | Respond with JSON. +streamEncoding :: Encoding -> IO Response +streamEncoding e = + return $ + responseLBS status200 [(hContentType, "application/json; charset=utf-8")] (encodingToLazyByteString e) + +-- | Respond with text. +textResponse :: TL.Text -> IO Response +textResponse t = + return $ + responseLBS status200 [(hContentType, "text/plain; charset=utf-8")] (TL.encodeUtf8 t) + +-- | Encode a response in binary, JSON or pretty JSON. +protoSerial :: + (Serial a) => + SerialAs -> + (a -> Encoding) -> + (a -> Value) -> + a -> + L.ByteString +protoSerial SerialAsBinary _ _ = runPutL . serialize +protoSerial SerialAsJSON f _ = encodingToLazyByteString . f +protoSerial SerialAsPrettyJSON _ g = + encodePretty' defConfig {confTrailingNewline = True} . g + +-- | The content type of an encoding. +serialType :: SerialAs -> C.ByteString +serialType SerialAsBinary = "application/octet-stream" +serialType _ = "application/json" + +-- | Whether a request asks for the binary encoding: its @Accept@ header +-- names @application\/octet-stream@, and gives it no less weight than it +-- gives JSON. +-- +-- The header is a list of media types, each with a weight from 0 to 1, +-- written @;q=@, that is 1 when left out. Binary is what is sent when +-- @application\/octet-stream@ is in the list with a weight above 0 that is +-- at least that of @application\/json@, if that is there too. A wildcard +-- such as @*\/*@ asks for nothing in particular and gets JSON, the +-- default, as does a request without the header. The header used to be +-- compared with the one string, so that a client that sent a list, or a +-- weight, got JSON without being told. +wantsBinary :: Req -> Bool +wantsBinary req = maybe False acceptsBinary (Router.header req "accept") + +-- | 'wantsBinary', given the value of the @Accept@ header. +acceptsBinary :: Text -> Bool +acceptsBinary accept = + case weight "application/octet-stream" of + Just q | q > 0 -> maybe True (q >=) (weight "application/json") + _ -> False + where + ranges = map range (T.splitOn "," accept) + weight name = lookup name ranges + range :: Text -> (Text, Double) + range part = case map T.strip (T.splitOn ";" part) of + [] -> ("", 0) + name : params -> (T.toLower name, fromMaybe 1 (listToMaybe (mapMaybe quality params))) + quality setting = case T.splitOn "=" setting of + [k, v] | T.toLower (T.strip k) == "q" -> readMaybe (T.unpack (T.strip v)) <|> Just 0 + _ -> Nothing + +-- | The encoding that a request asks for: binary if it 'wantsBinary', else +-- JSON, pretty if the @pretty@ parameter or the default says so. +serialAs :: Req -> Bool -> IO SerialAs +serialAs req pretty + | wantsBinary req = return SerialAsBinary + | otherwise = do + p <- paramOr req readBool "pretty" pretty + return $ if p then SerialAsPrettyJSON else SerialAsJSON + +-- GET Block / GET Blocks -- + +-- | Handler for @GET \/block\/:block@: a block by hash. +handleBlock :: + WebState -> + GetBlock -> + IO BlockData +handleBlock st (GetBlock h (NoTx noTx)) = withMetrics st (.block) $ do + st.query.getBlock h >>= \case + Nothing -> + raise st ThingNotFound + Just b -> do + return $ pruneTx noTx b + +-- | Blocks by hash, without duplicates, leaving out unknown ones. +getBlocks :: + WebState -> + [H.BlockHash] -> + Bool -> + IO [BlockData] +getBlocks st hs notx = + (pruneTx notx <$>) . catMaybes <$> mapM (st.query.getBlock) (nub hs) + +-- | Handler for @GET \/blocks?blocks=…@: several blocks by hash. +handleBlocks :: + WebState -> + GetBlocks -> + IO [BlockData] +handleBlocks st (GetBlocks hs (NoTx notx)) = + withMetrics st (.block) $ + getBlocks st hs notx + +-- | Keep only the coinbase in the list of transactions of a block, if the flag is 'True'. +pruneTx :: Bool -> BlockData -> BlockData +pruneTx False b = b +pruneTx True BlockData {..} = BlockData {txs = take 1 txs, ..} + +-- GET BlockRaw -- + +-- | Handler for @GET \/block\/:block\/raw@: a block by hash, serialized as in the peer-to-peer protocol. +handleBlockRaw :: + WebState -> + GetBlockRaw -> + IO (RawResult H.Block) +handleBlockRaw st (GetBlockRaw h) = + withMetrics st (.blockRaw) $ + RawResult <$> getRawBlock st h + +-- | Block by hash with all its transactions. Responds with an error if not found. +getRawBlock :: + WebState -> + H.BlockHash -> + IO H.Block +getRawBlock st h = + st.query.getBlock h >>= maybe (raise st ThingNotFound) return >>= toRawBlock st.query + +-- | Rebuild a block from its data and its transactions. +toRawBlock :: StoreRead -> BlockData -> IO H.Block +toRawBlock q b = do + txs <- map transactionData . catMaybes <$> C.getTransactions q b.txs + return H.Block {header = b.header, txs} + +-- GET BlockBest / BlockBestRaw -- + +-- | Handler for @GET \/block\/best@: the best block. +handleBlockBest :: + WebState -> + GetBlockBest -> + IO BlockData +handleBlockBest st (GetBlockBest (NoTx notx)) = + withMetrics st (.block) $ + (bestBlock st.query) >>= maybe (raise st ThingNotFound) (return . pruneTx notx) + +-- | Handler for @GET \/block\/best\/raw@: the best block, serialized. +handleBlockBestRaw :: + WebState -> + GetBlockBestRaw -> + IO (RawResult H.Block) +handleBlockBestRaw st _ = + withMetrics st (.blockRaw) $ + st.query.getBestBlock >>= \case + Nothing -> raise st ThingNotFound + Just h -> RawResult <$> getRawBlock st h + +-- GET BlockLatest -- + +-- | Handler for @GET \/block\/latest@: the best block and its ancestors, up to 100 blocks. +handleBlockLatest :: + WebState -> + GetBlockLatest -> + IO [BlockData] +handleBlockLatest st (GetBlockLatest (NoTx noTx)) = + withMetrics st (.block) $ + st.query.getBestBlock >>= maybe (raise st ThingNotFound) (go [] <=< st.query.getBlock) + where + go acc Nothing = return $ reverse acc + go acc (Just b) + | b.height <= 0 = return $ reverse acc + | length acc == 99 = return . reverse $ pruneTx noTx b : acc + | otherwise = go (pruneTx noTx b : acc) =<< st.query.getBlock b.header.prev + +-- GET BlockHeight / BlockHeights / BlockHeightRaw -- + +-- | Handler for @GET \/block\/height\/:height@: the blocks at a height. +handleBlockHeight :: + WebState -> + GetBlockHeight -> + IO [BlockData] +handleBlockHeight st (GetBlockHeight h (NoTx notx)) = + withMetrics st (.block) $ + st.query.getBlocksAtHeight (fromIntegral h) + >>= (\hs -> getBlocks st hs notx) + +-- | Handler for @GET \/block\/heights?heights=…@: the blocks at several heights. +handleBlockHeights :: + WebState -> + GetBlockHeights -> + IO [BlockData] +handleBlockHeights st (GetBlockHeights (HeightsParam heights) (NoTx notx)) = + withMetrics st (.block) $ + mapM (st.query.getBlocksAtHeight . fromIntegral) heights + >>= (\hs -> getBlocks st hs notx) . concat + +-- | Handler for @GET \/block\/height\/:height\/raw@: the blocks at a height, serialized. +handleBlockHeightRaw :: + WebState -> + GetBlockHeightRaw -> + IO (RawResultList H.Block) +handleBlockHeightRaw st (GetBlockHeightRaw h) = + withMetrics st (.blockRaw) $ + fmap RawResultList $ + mapM (getRawBlock st) =<< st.query.getBlocksAtHeight (fromIntegral h) + +-- GET BlockTime / BlockTimeRaw -- + +-- | Handler for @GET \/block\/time\/:time@: the last block with a timestamp at or before a time. +handleBlockTime :: + WebState -> + GetBlockTime -> + IO BlockData +handleBlockTime st (GetBlockTime (TimeParam t) (NoTx notx)) = + withMetrics st (.block) $ do + let ch = st.config.store.chain + C.blockAtOrBefore st.query ch t >>= \case + Nothing -> raise st ThingNotFound + Just b -> return $ pruneTx notx b + +-- | Handler for @GET \/block\/mtp\/:time@: the first block with a median time past at or after a time. +handleBlockMTP :: + WebState -> + GetBlockMTP -> + IO BlockData +handleBlockMTP st (GetBlockMTP (TimeParam t) (NoTx notx)) = + withMetrics st (.block) $ do + let ch = st.config.store.chain + C.blockAtOrAfterMTP st.query ch t >>= \case + Nothing -> raise st ThingNotFound + Just b -> return $ pruneTx notx b + +-- | Handler for @GET \/block\/time\/:time\/raw@: the last block with a timestamp at or before a time, serialized. +handleBlockTimeRaw :: + WebState -> + GetBlockTimeRaw -> + IO (RawResult H.Block) +handleBlockTimeRaw st (GetBlockTimeRaw (TimeParam t)) = + withMetrics st (.blockRaw) $ do + let ch = st.config.store.chain + C.blockAtOrBefore st.query ch t >>= \case + Nothing -> raise st ThingNotFound + Just b -> RawResult <$> (toRawBlock st.query b) + +-- | Handler for @GET \/block\/mtp\/:time\/raw@: the first block with a median time +-- past at or after a time, serialized. +handleBlockMTPRaw :: + WebState -> + GetBlockMTPRaw -> + IO (RawResult H.Block) +handleBlockMTPRaw st (GetBlockMTPRaw (TimeParam t)) = + withMetrics st (.blockRaw) $ do + let ch = st.config.store.chain + C.blockAtOrAfterMTP st.query ch t >>= \case + Nothing -> raise st ThingNotFound + Just b -> RawResult <$> (toRawBlock st.query b) + +-- GET Transactions -- + +-- | Handler for @GET \/transaction\/:txid@: a transaction. +handleTx :: WebState -> GetTx -> IO Transaction +handleTx st (GetTx txid) = + withMetrics st (.tx) $ + C.getTransaction st.query txid >>= maybe (raise st ThingNotFound) return + +-- | Handler for @GET \/transactions?txids=…@: several transactions. +handleTxs :: + WebState -> + GetTxs -> + IO [Transaction] +handleTxs st (GetTxs txids) = + withMetrics st (.tx) $ + catMaybes <$> C.getTransactions st.query (nub txids) + +-- | Handler for @GET \/transaction\/:txid\/raw@: a transaction, serialized. +handleTxRaw :: + WebState -> + GetTxRaw -> + IO (RawResult Tx) +handleTxRaw st (GetTxRaw txid) = + withMetrics st (.txRaw) $ + C.getTransaction st.query txid + >>= \case + Nothing -> raise st ThingNotFound + Just tx -> return $ RawResult (transactionData tx) + +-- | Handler for @GET \/transactions\/raw?txids=…@: several transactions, serialized. +handleTxsRaw :: + WebState -> + GetTxsRaw -> + IO (RawResultList Tx) +handleTxsRaw st (GetTxsRaw txids) = + withMetrics st (.txRaw) $ + RawResultList . map transactionData . catMaybes + <$> C.getTransactions st.query (nub txids) + +-- | Transactions of a block. Responds with an error if not found. +getTxsBlock :: + WebState -> + H.BlockHash -> + IO [Transaction] +getTxsBlock st h = + st.query.getBlock h >>= \case + Nothing -> raise st ThingNotFound + Just b -> catMaybes <$> C.getTransactions st.query b.txs + +-- | Handler for @GET \/transactions\/block\/:block@: the transactions of a block. +handleTxsBlock :: + WebState -> + GetTxsBlock -> + IO [Transaction] +handleTxsBlock st (GetTxsBlock h) = + withMetrics st (.txBlock) $ getTxsBlock st h + +-- | Handler for @GET \/transactions\/block\/:block\/raw@: the transactions of a block, serialized. +handleTxsBlockRaw :: + WebState -> + GetTxsBlockRaw -> + IO (RawResultList Tx) +handleTxsBlockRaw st (GetTxsBlockRaw h) = + withMetrics st (.txBlockRaw) $ + RawResultList . map transactionData <$> getTxsBlock st h + +-- GET TransactionAfterHeight -- + +-- | Handler for @GET \/transaction\/:txid\/after\/:height@: whether any ancestor +-- of a transaction is a coinbase confirmed after a height. +handleTxAfter :: + WebState -> + GetTxAfter -> + IO (GenericResult (Maybe Bool)) +handleTxAfter st (GetTxAfter txid height) = + withMetrics st (.txAfter) $ + GenericResult . fst <$> (cbAfterHeight st.query (fromIntegral height) txid) + +-- | Check if any of the ancestors of this transaction is a coinbase after the +-- specified height. Returns 'Nothing' if answer cannot be computed before +-- hitting limits. +cbAfterHeight :: + StoreRead -> + H.BlockHeight -> + TxHash -> + IO (Maybe Bool, Int) +cbAfterHeight q height txid = + inputs n HashSet.empty HashSet.empty [txid] + where + n = 10000 + inputs 0 _ _ [] = return (Nothing, 10000) + inputs i is ns [] = + let is' = HashSet.union is ns + ns' = HashSet.empty + ts = HashSet.toList (HashSet.difference ns is) + in case ts of + [] -> return (Just False, n - i) + _ -> inputs i is' ns' ts + inputs i is ns (t : ts) = + C.getTransaction q t >>= \case + Nothing -> return (Nothing, n - i) + Just tx + | height_check tx -> + if cb_check tx + then return (Just True, n - i + 1) + else + let ns' = HashSet.union (ins tx) ns + in inputs (i - 1) is ns' ts + | otherwise -> inputs (i - 1) is ns ts + cb_check = any isCoinbase . (.inputs) + ins = HashSet.fromList . map (.outpoint.hash) . (.inputs) + height_check tx = + case tx.block of + BlockRef h _ -> h > height + MemRef _ -> True + +-- POST Transaction -- + +-- | Handler for @POST \/transactions@: broadcast a transaction to half of the peers and return its hash. +handlePostTx :: WebState -> PostTx -> IO TxId +handlePostTx st (PostTx tx) = + withMetrics st (.txPost) $ do + let cfg = st.config + (publishTx cfg tx) + return (TxId (txHash tx)) + +-- | Send transaction to all connected peers. +publishTx :: + WebConfig -> + Tx -> + IO () +publishTx cfg tx = do + ps <- getPeers cfg.store.peerMgr + let c = max 1 (length ps `div` 2) + forM_ (take c ps) $ \p -> do + sendMessage (MTx tx) p.mailbox + void . async $ do + threadDelay (5 * 1000 * 1000) + let v = if cfg.store.net.segWit then InvWitnessTx else InvTx + g = MGetData (GetData [InvVector v (txHash tx).get]) + sendMessage g p.mailbox + +-- GET Mempool / Events -- + +-- | Handler for @GET \/mempool@: hashes of mempool transactions, newest first. +handleMempool :: + WebState -> + GetMempool -> + IO [TxHash] +handleMempool st (GetMempool limitM (OffsetParam o)) = + withMetrics st (.mempool) $ do + WebLimits {..} <- pure st.config.limits + let wl' = WebLimits {maxItemCount = 0, ..} + l = Limits (validateLimit wl' False limitM) (fromIntegral o) Nothing + map snd <$> st.query.getMempoolPage l + +-- | Middleware that serves @\/events@ over a WebSocket: each new block and +-- each transaction that enters or leaves the mempool is a message, from the +-- log of events ("Haskoin.Store.Web.Events"). +-- +-- The client may send the commands of t'EventCommand' to choose the +-- transactions that it hears about. Each side speaks JSON in text frames +-- or binary in binary frames, and the server speaks as it was last spoken +-- to; before the client has said anything, as the @Accept@ header of the +-- handshake asks, like any request. A command that the server cannot read +-- or cannot do closes the connection with the reason, as a node does with +-- an SPV client: there are no answers to wait for. +-- +-- @?after=@ with the hash of the last event heard takes up from there +-- ('eventsStart'). Clients that do not answer pings, or that fall off the +-- start of the log, are disconnected. +webSocketEvents :: WebState -> Middleware +webSocketEvents s = + websocketsOr defaultConnectionOptions (wrap . events) + where + pingPong = defaultPingPongOptions {pingInterval = 30, pongTimeout = 60} + gauge = (.events) <$> s.metrics + net = s.config.store.net + ctx = s.config.store.ctx + gap = s.query.maxGap + wrap f = case gauge of + Nothing -> f + Just g -> withGaugeIO g f + events pending = do + let request = pendingRequest pending + (path, query) = C.break (== '?') (requestPath request) + asked = parseQuery query + accept = lookup "Accept" (WebSockets.requestHeaders request) + binary = maybe False (acceptsBinary . T.decodeUtf8Lenient) accept + if path /= "/events" + then turnAway pending ThingNotFound + else + eventsOpen s (\name -> T.decodeUtf8Lenient <$> join (lookup (T.encodeUtf8 name) asked)) >>= \case + Left e -> turnAway pending e + Right (start, watch) -> do + conn <- acceptRequest pending + format <- newTVarIO binary + -- websockets only sees pongs while reading, which the + -- thread that hears the commands does + withPingPong pingPong conn $ \c -> + race_ (hear c watch format) (tell c watch format start) `catch` gone + -- a client that leaves is not an error to report + gone :: WebSockets.ConnectionException -> IO () + gone _ = return () + -- the commands of the client, until one cannot be done + hear c watch format = do + message <- WebSockets.receiveDataMessage c + let (binary, read') = case message of + WebSockets.Text bytes _ -> (False, A.decode bytes >>= parseMaybe (unmarshalValue (net, ctx))) + WebSockets.Binary bytes -> (True, either (const Nothing) Just (unmarshal (net, ctx) (L.toStrict bytes))) + atomically (writeTVar format binary) + case read' of + Nothing -> refuse c "Could not read the command" + Just cmd -> + try (command ctx gap s.query.xPubBals watch cmd) >>= \case + Right (Right ()) -> hear c watch format + Right (Left why) -> refuse c why + Left (_ :: Except) -> refuse c "Could not do the command" + -- 1008: the message is against what the server allows + refuse c why = WebSockets.sendCloseCode c 1008 (T.pack why) + -- the events from a place in the log on, those that the client chose + tell c watch format from = + atomically (readEvents s.eventLog from) >>= \case + Nothing -> WebSockets.sendClose c ("Event queue full" :: Text) + Just entries -> do + forM_ entries $ \e -> do + wanted <- atomically (stateTVar watch (relevant ctx gap e.seen)) + when wanted $ + readTVarIO format >>= \case + True -> sendBinaryData c (runPutL (serialize e.event)) + False -> sendTextData c (A.encode e.event) + tell c watch format (from + fromIntegral (length entries)) + turnAway pending e = + rejectRequestWith + pending + WebSockets.defaultRejectRequest + { WebSockets.rejectBody = L.toStrict (A.encode e), + WebSockets.rejectCode = statusCode (errStatus e), + WebSockets.rejectMessage = statusMessage (errStatus e), + WebSockets.rejectHeaders = [("Content-Type", "application/json")] + } + +-- | Handler for @GET \/events@: stream of new blocks and of transactions +-- that enter or leave the mempool, one per line in JSON or one after the +-- other in binary, until the client falls off the start of the log. +-- @after@ takes up from an event ('eventsStart'). +handleEvents :: WebState -> Req -> IO Response +handleEvents st req = do + proto <- serialAs req False + let asked name = lookup name req.params + (start, watch) <- eventsOpen st asked >>= either (raise st) return + return . responseStream status200 [(hContentType, serialType proto)] $ \write flush' -> + let send from = do + flush' + -- ends the response when the client falls too far behind + atomically (readEvents st.eventLog from) >>= \case + Nothing -> return () + Just entries -> do + forM_ entries $ \e -> do + wanted <- atomically (stateTVar watch (relevant own.ctx st.query.maxGap e.seen)) + when wanted (write (serial proto e.event)) + send (from + fromIntegral (length entries)) + in withGaugeIncrease st (.events) (send start) + where + serial proto e = + lazyByteString $ + protoSerial proto toEncoding toJSON e <> newLine proto + newLine SerialAsBinary = mempty + newLine SerialAsJSON = "\n" + newLine SerialAsPrettyJSON = mempty + own = st.config.store + +-- | Where a client of the events starts reading the log, and what it hears +-- about from the start, as the parameters of its request say: 'eventsStart' +-- for @after@, and for the rest a choice made of the same commands that a +-- WebSocket client sends later. +-- +-- A WebSocket client could only choose once it was connected, and until its +-- first command was read it was sent every transaction of a busy mempool. +-- With these the choice is there before the first event: +-- +-- * @quiet=true@: no transactions, only blocks, until something is watched; +-- * @addresses@: a list of addresses to watch, separated by commas; +-- * @xpub@ and @derive@: an extended public key and the types of its +-- addresses, one or several separated by commas, legacy if left out; +-- * @filter@, @functions@, @tweak@, @flags@: a Bloom filter, in hex, with +-- its numbers. +-- +-- Any of them but @quiet=false@ makes the client a filtered one. The HTTP +-- stream takes them too, and it is the only way that it has to choose. +-- The place in the log is taken first, so that nothing that happens while +-- a key is read from the database is left out. +eventsOpen :: WebState -> (Text -> Maybe Text) -> IO (Either Except (Word64, TVar Watch)) +eventsOpen st asked = + eventsStart st (asked "after") >>= \case + Left e -> return (Left e) + Right start -> case commands of + Left why -> return (Left (UserError why)) + Right cmds -> do + watch <- newTVarIO everything + let run [] = return (Right (start, watch)) + run (cmd : rest) = + command own.ctx st.query.maxGap st.query.xPubBals watch cmd >>= \case + Left why -> return (Left (UserError why)) + Right () -> run rest + run cmds + where + own = st.config.store + commands = do + quiet <- maybe (Right False) (need "quiet" . readBool) (asked "quiet") + addresses <- mapM (need "addresses" . textToAddr own.net) (listed "addresses") + derivs <- mapM (need "derive" . textToDeriveType) (listed "derive") + keys <- mapM (need "xpub" . xPubImport own.net own.ctx) (maybe [] pure (asked "xpub")) + filters <- case asked "filter" of + Nothing -> Right [] + Just hex -> do + let number name = maybe (Right 0) (need name . (readNum :: Text -> Maybe Word32)) (asked name) + functions <- number "functions" + tweak <- number "tweak" + flags <- number "flags" + let json = + A.object + [ "type" A..= A.String "filterload", + "filter" A..= hex, + "functions" A..= functions, + "tweak" A..= tweak, + "flags" A..= flags + ] + pure <$> need "filter" (parseMaybe (unmarshalValue (own.net, own.ctx)) json) + when (null keys && not (null derivs)) (Left "Parameter derive needs xpub") + let types = if null derivs then [DeriveNormal] else derivs + return $ + [EventNone | quiet] + <> [EventWatch addresses | not (null addresses)] + <> [EventWatchXPub XPubSpec {key, deriv} | key <- keys, deriv <- types] + <> filters + listed name = maybe [] (filter (not . T.null) . T.splitOn ",") (asked name) + need :: Text -> Maybe a -> Either String a + need name = maybe (Left ("Could not read parameter " <> T.unpack name)) Right + +-- | Where a client of the events starts reading the log: at the end, or +-- after the event that it says it heard last, named by the hash of its +-- block or transaction. 404 when the log has no event with that hash: the +-- client cannot know what it missed, and has to read what it follows again +-- and listen from the end. +eventsStart :: WebState -> Maybe Text -> IO (Either Except Word64) +eventsStart st = \case + Nothing -> Right <$> atomically (eventsEnd st.eventLog) + Just hex -> case (H.hexToBlockHash hex, hexToTxHash hex) of + (Nothing, Nothing) -> return (Left (UserError "The parameter after is not a hash")) + (block, tx) -> maybe (Left ThingNotFound) Right <$> atomically (eventsAfter st.eventLog block tx) + +-- | Write what happens into the log of events for as long as the server +-- runs, each transaction that enters with what the database has of it +-- ('seenOf'), for the clients that choose what they hear about. +-- +-- A store alone writes what it publishes. A member of a fleet writes what +-- the fleet tells ('memberEvents'), from the start of what Redis keeps, so +-- that the logs of all the servers of a fleet hold the same events and a +-- client can take up on any of them. +feedEvents :: WebState -> IO () +feedEvents st = case own.fleet of + Just member -> memberEvents member True (mapM_ happened . fleet) complain + Nothing -> do + queue <- newTQueueIO + let listen = mapM_ (writeTQueue queue) . local + bracket (subscribe own.pub listen) (unsubscribe own.pub) $ \_ -> + forever (atomically (readTQueue queue) >>= happened) + where + own = st.config.store + local = \case + StoreBestBlock b -> Just (Left b) + StoreMempoolNew t -> Just (Right (t, True)) + StoreMempoolDelete t -> Just (Right (t, False)) + _ -> Nothing + fleet = \case + FleetBlock h -> Left <$> hash h + FleetEntered h -> Right . (,True) <$> hash h + FleetLeft h -> Right . (,False) <$> hash h + hash :: (Serialize x) => C.ByteString -> Maybe x + hash = either (const Nothing) Just . decode + happened = \case + Left b -> atomically (appendEvent st.eventLog (BlockArrived b)) + Right (t, False) -> atomically (appendEvent st.eventLog (TxLeft t)) + Right (t, True) -> do + -- a transaction that cannot be read is told to every client + known <- st.direct.getTxData t `catchAny` \_ -> return Nothing + atomically (appendEvent st.eventLog (TxEntered t (seenOf own.net own.ctx <$> known))) + complain why = logError (withSource "Events" st.config.logger) ("Could not read the events: " <> cs why) + +-- GET Address Transactions -- + +-- | Handler for @GET \/address\/:address\/transactions@: transactions of an address. +handleAddrTxs :: + WebState -> + GetAddrTxs -> + IO [TxRef] +handleAddrTxs st (GetAddrTxs addr pLimits) = + withMetrics st (.addressTx) $ + st.query.getAddressTxs addr =<< paramToLimits st False pLimits + +-- | Handler for @GET \/address\/transactions?addresses=…@: transactions of several addresses. +handleAddrsTxs :: + WebState -> + GetAddrsTxs -> + IO [TxRef] +handleAddrsTxs st (GetAddrsTxs addrs pLimits) = + withMetrics st (.addressTx) $ + st.query.getAddressesTxs addrs =<< paramToLimits st False pLimits + +-- | Handler for @GET \/address\/:address\/transactions\/full@: full transactions of an address. +handleAddrTxsFull :: + WebState -> + GetAddrTxsFull -> + IO [Transaction] +handleAddrTxsFull st (GetAddrTxsFull addr pLimits) = + withMetrics st (.addressTxFull) $ do + txs <- st.query.getAddressTxs addr =<< paramToLimits st True pLimits + catMaybes <$> C.getTransactions st.query (map (.txid) txs) + +-- | Handler for @GET \/address\/transactions\/full?addresses=…@: full transactions of several addresses. +handleAddrsTxsFull :: + WebState -> + GetAddrsTxsFull -> + IO [Transaction] +handleAddrsTxsFull st (GetAddrsTxsFull addrs pLimits) = + withMetrics st (.addressTxFull) $ do + txs <- st.query.getAddressesTxs addrs =<< paramToLimits st True pLimits + catMaybes <$> C.getTransactions st.query (map (.txid) txs) + +-- | Handler for @GET \/address\/:address\/balance@: balance of an address. +handleAddrBalance :: WebState -> GetAddrBalance -> IO Balance +handleAddrBalance st (GetAddrBalance addr) = + withMetrics st (.addressBalance) $ C.getDefaultBalance st.query addr + +-- | Handler for @GET \/address\/balances?addresses=…@: balances of several addresses. +handleAddrsBalance :: + WebState -> + GetAddrsBalance -> + IO [Balance] +handleAddrsBalance st (GetAddrsBalance addrs) = + withMetrics st (.addressBalance) $ st.query.getBalances addrs + +-- | Handler for @GET \/address\/:address\/unspent@: unspent outputs of an address. +handleAddrUnspent :: + WebState -> + GetAddrUnspent -> + IO [Unspent] +handleAddrUnspent st (GetAddrUnspent addr pLimits) = + withMetrics st (.addressUnspent) $ + st.query.getAddressUnspents addr =<< paramToLimits st False pLimits + +-- | Handler for @GET \/address\/unspent?addresses=…@: unspent outputs of several addresses. +handleAddrsUnspent :: + WebState -> + GetAddrsUnspent -> + IO [Unspent] +handleAddrsUnspent st (GetAddrsUnspent addrs pLimits) = + withMetrics st (.addressUnspent) $ + st.query.getAddressesUnspents addrs =<< paramToLimits st False pLimits + +-- GET XPubs -- + +-- | Handler for @GET \/xpub\/:xpub@: summary of an extended public key. +handleXPub :: + WebState -> + GetXPub -> + IO XPubSummary +handleXPub st (GetXPub xpub deriv (NoCache noCache)) = + withMetrics st (.xpub) $ + let xs = XPubSpec xpub deriv + in xPubSummary xs <$> xPubBalsChecked st noCache xs + +-- | Handler for @DELETE \/xpub\/:xpub@: remove an extended public key from the cache. Returns 'True' if it was cached. +handleDelXPub :: + WebState -> + DelCachedXPub -> + IO (GenericResult Bool) +handleDelXPub st (DelCachedXPub xpub deriv) = + withMetrics st (.xpubDelete) $ do + let c = st.config.store.cache + r <- maybe (return False) (`cacheDelete` XPubSpec xpub deriv) c + return $ GenericResult r + +-- | Balances of the addresses of an extended public key ('xPubBals'), from +-- the cache unless told not to, refusing a wrong kind of address +-- ('checkDerive'). +xPubBalsChecked :: WebState -> Bool -> XPubSpec -> IO [XPubBal] +xPubBalsChecked st noCache xs = do + bals <- (cacheOr noCache st).query.xPubBals xs + checkDerive st xs bals + return bals + +-- | Answer with an error if an extended public key has no transactions with +-- the kind of address asked for, but has some with another kind: the request +-- named the wrong kind. +-- +-- An xpub does not record which kind of address its wallet derives, and the +-- same key gives different addresses for each kind, so a request with the +-- wrong @derive@ would otherwise get an empty wallet: a valid answer, and a +-- wrong one, that a wallet would show its user as a zero balance. An error +-- says what went wrong and how to fix it. +-- +-- The check costs nothing for a wallet that has transactions. For one that +-- looks unused, it reads the balances of the first addresses of each other +-- kind, as many as the store reads to decide that an xpub is unused, in one +-- read per kind. A wallet unused with every kind is a new wallet, and gets its +-- empty answer. Networks without SegWit have one kind only, and no check. +checkDerive :: WebState -> XPubSpec -> [XPubBal] -> IO () +checkDerive st xs bals = + when (net.segWit && all (\b -> b.balance.txs == 0) bals) $ do + used <- filterM usedAs others + forM_ (take 1 used) $ \d -> + raise st . UserError $ + unwords + [ "This xpub has no transactions with derive=" <> name xs.deriv <> ",", + "but has some with derive=" <> name d <> ";", + "ask with derive=" <> name d <> "." + ] + where + net = st.config.store.net + ctx = st.config.store.ctx + others = filter (/= xs.deriv) [DeriveNormal, DeriveP2SH, DeriveP2WPKH] + name = T.unpack . deriveTypeToText + usedAs d = do + let external = pubSubKey ctx xs.key 0 + addrs = + map snd . take (fromIntegral st.query.initialGap) $ + deriveAddresses (deriveFunction ctx d) external 0 + any (\b -> b.txs > 0) <$> st.query.getBalances addrs + +-- | Transactions of an extended public key, optionally without the cache. +getXPubTxs :: + WebState -> + XPubKey -> + DeriveType -> + LimitsParam -> + Bool -> + IO [TxRef] +getXPubTxs st xpub deriv plimits nocache = do + limits <- paramToLimits st False plimits + let xs = XPubSpec xpub deriv + st' = cacheOr nocache st + xbals <- xPubBalsChecked st nocache xs + st'.query.xPubTxs xs xbals limits + +-- | Handler for @GET \/xpub\/:xpub\/transactions@: transactions of an extended public key. +handleXPubTxs :: + WebState -> + GetXPubTxs -> + IO [TxRef] +handleXPubTxs st (GetXPubTxs xpub deriv plimits (NoCache nocache)) = + withMetrics st (.xpubTx) $ + getXPubTxs st xpub deriv plimits nocache + +-- | Handler for @GET \/xpub\/:xpub\/transactions\/full@: full transactions of an extended public key. +handleXPubTxsFull :: + WebState -> + GetXPubTxsFull -> + IO [Transaction] +handleXPubTxsFull st (GetXPubTxsFull xpub deriv plimits (NoCache nocache)) = + withMetrics st (.xpubTxFull) $ + fmap catMaybes $ + C.getTransactions (cacheOr nocache st).query . map (.txid) + =<< getXPubTxs st xpub deriv plimits nocache + +-- | Handler for @GET \/xpub\/:xpub\/balances@: balances of the used addresses of an extended public key. +handleXPubBalances :: + WebState -> + GetXPubBalances -> + IO [XPubBal] +handleXPubBalances st (GetXPubBalances xpub deriv (NoCache noCache)) = + withMetrics st (.xpubBalance) $ + xPubBalsChecked st noCache (XPubSpec xpub deriv) + +-- | Handler for @GET \/xpub\/:xpub\/unspent@: unspent outputs of an extended public key. +handleXPubUnspent :: + WebState -> + GetXPubUnspent -> + IO [XPubUnspent] +handleXPubUnspent st (GetXPubUnspent xpub deriv pLimits (NoCache noCache)) = + withMetrics st (.xpubUnspent) $ do + limits <- paramToLimits st False pLimits + let xspec = XPubSpec xpub deriv + st' = cacheOr noCache st + xbals <- xPubBalsChecked st noCache xspec + st'.query.xPubUnspents xspec xbals limits + +--------------------------------------- +-- Blockchain.info API Compatibility -- +--------------------------------------- + +-- | Currency symbol of the coin of a network, in the Blockchain.info format. +netBinfoSymbol :: Network -> BinfoSymbol +netBinfoSymbol net + | net == btc = + BinfoSymbol + { code = "BTC", + symbol = "BTC", + name = "Bitcoin", + conversion = 100 * 1000 * 1000, + after = True, + local = False + } + | net == bch = + BinfoSymbol + { code = "BCH", + symbol = "BCH", + name = "Bitcoin Cash", + conversion = 100 * 1000 * 1000, + after = True, + local = False + } + | otherwise = + BinfoSymbol + { code = "XTS", + symbol = "¤", + name = "Test", + conversion = 100 * 1000 * 1000, + after = False, + local = False + } + +-- | Currency symbol of a fiat currency from its price ticker. +binfoTickerToSymbol :: Text -> BinfoTicker -> BinfoSymbol +binfoTickerToSymbol code t = + BinfoSymbol + { code, + symbol = t.symbol, + name, + conversion = 100 * 1000 * 1000 / t.fifteen, -- sat/usd + after = False, + local = True + } + where + name = case code of + "EUR" -> "Euro" + "USD" -> "U.S. dollar" + "GBP" -> "British pound" + x -> x + +-- | Addresses and xpubs in a request parameter, separated by pipes or commas. +getBinfoAddrsParam :: + WebState -> + Req -> + Text -> + IO (HashSet BinfoAddr) +getBinfoAddrsParam st req name = do + let net = st.config.store.net + let ctx = st.config.store.ctx + p <- fromMaybe "" <$> param req name + if T.null p + then return HashSet.empty + else case parseBinfoAddr net ctx p of + Nothing -> raise st (UserError "invalid address") + Just xs -> return $ HashSet.fromList xs + +-- | Xpubs and addresses in the @active@, @activeP2SH@ and @activeBech32@ +-- parameters. Xpubs in each parameter derive legacy, nested SegWit and native +-- SegWit addresses. +getBinfoActive :: + WebState -> + Req -> + IO (HashSet XPubSpec, HashSet Address) +getBinfoActive st req = do + active <- getBinfoAddrsParam st req "active" + p2sh <- getBinfoAddrsParam st req "activeP2SH" + bech32 <- getBinfoAddrsParam st req "activeBech32" + let xspec d b = (`XPubSpec` d) <$> xpub b + xspecs = + HashSet.fromList $ + concat + [ mapMaybe (xspec DeriveNormal) (HashSet.toList active), + mapMaybe (xspec DeriveP2SH) (HashSet.toList p2sh), + mapMaybe (xspec DeriveP2WPKH) (HashSet.toList bech32) + ] + addrs = HashSet.fromList $ mapMaybe addr $ HashSet.toList active + return (xspecs, addrs) + where + addr (BinfoAddr a) = Just a + addr (BinfoXpub _) = Nothing + xpub (BinfoXpub x) = Just x + xpub (BinfoAddr _) = Nothing + +-- | A kind of address to derive, as in the @derive@ parameter of the xpub +-- endpoints: SegWit kinds only on networks with SegWit. +readDerive :: Network -> Text -> Maybe DeriveType +readDerive net t = do + d <- textToDeriveType t + guard (net.segWit || d == DeriveNormal) + return d + +-- | Whether to identify transactions by short number, unless @txidindex@ is false. +getNumTxId :: Req -> IO Bool +getNumTxId req = not <$> paramOr req readBool "txidindex" False + +-- | Height of the best header. +getChainHeight :: WebState -> IO H.BlockHeight +getChainHeight st = + fmap (.height) $ chainGetBest =<< pure st.config.store.chain + +-- | Handler for @GET\/POST \/blockchain\/unspent@: unspent outputs of addresses and xpubs, as Blockchain.info. +handleBinfoUnspent :: WebState -> Req -> IO Response +handleBinfoUnspent st req = + withMetrics st (.binfoUnspent) $ do + (xspecs, addrs) <- getBinfoActive st req + numtxid <- getNumTxId req + limit <- get_limit + min_conf <- get_min_conf + let net = st.config.store.net + let ctx = st.config.store.ctx + height <- getChainHeight st + let mn u = min_conf > u.confirmations + xbals <- getXBals st.query xspecs + bus <- + runConduit $ + getBinfoUnspents st.query numtxid height xbals xspecs addrs + .| (dropWhileC mn >> takeC limit .| sinkList) + streamEncoding (marshalEncoding (net, ctx) (BinfoUnspents bus)) + where + get_limit = min 1000 . fromIntegral <$> paramOr req readNat "limit" 250 + get_min_conf = fromIntegral <$> paramOr req readNat "confirmations" 0 + +-- | Stream the unspent outputs of xpubs and addresses, newest first, in the +-- Blockchain.info format. +getBinfoUnspents :: + StoreRead -> + Bool -> + H.BlockHeight -> + HashMap XPubSpec [XPubBal] -> + HashSet XPubSpec -> + HashSet Address -> + ConduitT () BinfoUnspent IO () +getBinfoUnspents q numtxid height xbals xspecs addrs = do + cs' <- conduits + joinDescStreams (unspentKey . fst) cs' .| mapC (uncurry binfo) + where + binfo u xp = + let conf = case u.block of + MemRef _ -> 0 + -- an output from the cache may be in a block that the chain of + -- this store does not have yet: it is confirmed at least once + BlockRef h _ -> if h > height then 1 else height - h + 1 + in BinfoUnspent + { txid = u.outpoint.hash, + index = u.outpoint.index, + script = u.script, + value = u.value, + confirmations = fromIntegral conf, + txidx = encodeBinfoTxId numtxid u.outpoint.hash, + xpub = xp + } + conduits = (<>) <$> xconduits <*> pure acounduits + xconduits = lift $ do + let f x (XPubUnspent u p) = + let path = toSoft (listToPath p) + xp = BinfoXPubPath x.key <$> path + in (u, xp) + g x = do + let h = q.xPubUnspents x (xBals x xbals) + l = let Limits {..} = def in Limits {limit = 16, ..} + return $ streamThings h Nothing l .| mapC (f x) + mapM g (HashSet.toList xspecs) + acounduits = + let f u = (u, Nothing) + h = q.getAddressUnspents + l = let Limits {..} = def in Limits {limit = 16, ..} + g a = streamThings (h a) Nothing l .| mapC f + in map g (HashSet.toList addrs) + +-- | Balances of the used addresses of each xpub. +getXBals :: + StoreRead -> + HashSet XPubSpec -> + IO (HashMap XPubSpec [XPubBal]) +getXBals q = + fmap HashMap.fromList . mapM f . HashSet.toList + where + f x = (x,) . filter (not . nullBalance . (.balance)) <$> q.xPubBals x + +-- | Balances of an xpub, or none if missing. +xBals :: XPubSpec -> HashMap XPubSpec [XPubBal] -> [XPubBal] +xBals = HashMap.findWithDefault [] + +-- | Stream the references to the transactions of xpubs and addresses, newest +-- first, without duplicates. Each xpub and address is read page by page, only +-- as far as the consumer needs, in pages of the given size: about as many as +-- the consumer is expected to take, as every page is a query of its own. +binfoTxRefs :: + StoreRead -> + Word32 -> + HashMap XPubSpec [XPubBal] -> + HashSet XPubSpec -> + HashSet Address -> + ConduitT () TxRef IO () +binfoTxRefs q pageSize xbals sxspecs saddrs = + joinDescStreams txRefKey $ + map xpub_c (HashSet.toList sxspecs) <> map addr_c (HashSet.toList saddrs) + where + l = Limits {limit = pageSize, offset = 0, start = Nothing} + xpub_c x = streamThings (q.xPubTxs x (xBals x xbals)) (Just (.txid)) l + addr_c a = streamThings (q.getAddressTxs a) (Just (.txid)) l + +-- | Stream the transactions of xpubs and addresses, newest first, in the +-- Blockchain.info format, with the running balance of the given addresses after +-- each, keeping only those that pass the filter. +getBinfoTxs :: + StoreRead -> + Word32 -> -- page size of the references, as for 'binfoTxRefs' + HashMap XPubSpec [XPubBal] -> -- xpub balances + HashMap Address (Maybe BinfoXPubPath) -> -- address book + HashSet XPubSpec -> -- show xpubs + HashSet Address -> -- show addrs + HashSet Address -> -- balance addresses + BinfoFilter -> + Bool -> -- numtxid + Bool -> -- prune outputs + Int64 -> -- starting balance + ConduitT () BinfoTx IO () +getBinfoTxs + q + pageSize + xbals + abook + sxspecs + saddrs + baddrs + bfilter + numtxid + prune + bal = + binfoTxRefs q pageSize xbals sxspecs saddrs .| bodies .| go bal + where + binfo_tx = toBinfoTx numtxid abook prune + compute_bal_change t = + let ins = map (.output) t.inputs + out = t.outputs + f b BinfoTxOutput {..} = + let val = fromIntegral value + in case address of + Nothing -> 0 + Just a + | a `HashSet.member` baddrs -> + if b then val else negate val + | otherwise -> 0 + in sum $ map (f False) ins <> map (f True) out + -- the bodies, read a page at a time, which is one round trip to Redis + -- or one multi-get of the database instead of one per transaction + bodies = do + refs <- takeC (fromIntegral pageSize) .| sinkList + unless (null refs) $ do + lift (C.getTransactions q (map (.txid) refs)) >>= mapM_ yield + bodies + go b = + await >>= \case + Nothing -> return () + Just Nothing -> go b + Just (Just x) -> do + let a = binfo_tx b x + b' = b - compute_bal_change a + c = isJust a.blockHeight + d = fst (fromJust a.balance) + r = d + fromIntegral a.fee + case bfilter of + BinfoFilterAll -> + yield a >> go b' + BinfoFilterSent + | 0 > r -> yield a >> go b' + | otherwise -> go b' + BinfoFilterReceived + | r > 0 -> yield a >> go b' + | otherwise -> go b' + BinfoFilterMoved + | r == 0 -> yield a >> go b' + | otherwise -> go b' + BinfoFilterConfirmed + | c -> yield a >> go b' + | otherwise -> go b' + BinfoFilterMempool + | c -> return () + | otherwise -> yield a >> go b' + +-- | Page size to read the references of the transactions in, to show this +-- many after this offset: all of them in one page if they fit in 1000. +pageFor :: Int -> Int -> Word32 +pageFor offset n = fromIntegral (max 16 (min 1000 (offset + n))) + +-- | Whether to show addresses in CashAddr format (@cashaddr@). +getCashAddr :: Req -> IO Bool +getCashAddr req = paramOr req readBool "cashaddr" False + +-- | Parse an address. Responds with not found if invalid. +getAddress :: WebState -> Text -> IO Address +getAddress st txt = do + let net = st.config.store.net + case textToAddr net txt of + Nothing -> raise st ThingNotFound + Just a -> return a + +-- | Address or xpub in a path parameter. Passes to the next route if invalid. +getBinfoAddr :: WebState -> Req -> Text -> IO BinfoAddr +getBinfoAddr st req param' = do + txt <- capture req param' + let net = st.config.store.net + let ctx = st.config.store.ctx + let addr = BinfoAddr <$> textToAddr net txt + xpub = BinfoXpub <$> xPubImport net ctx txt + maybe next return (addr <|> xpub) + +-- | Handler for @GET\/POST \/blockchain\/export-history@: daily history of the +-- balance of addresses and xpubs with prices, as Blockchain.info. +handleBinfoHistory :: WebState -> Req -> IO Response +handleBinfoHistory st req = + withMetrics st (.binfoExportHistory) $ do + (xspecs, addrs) <- getBinfoActive st req + (startM, endM) <- get_dates + (code, price') <- getPrice st req + xbals <- (getXBals st.query xspecs) + let xaddrs = HashSet.fromList $ concatMap (map get_addr) (HashMap.elems xbals) + aaddrs = xaddrs <> addrs + cur = price'.fifteen + cs' = conduits (HashMap.toList xbals) addrs endM + txs <- + runConduit $ + joinDescStreams txRefKey cs' + .| takeWhileC (is_newer startM) + .| concatMapMC get_transaction + .| sinkList + let times = map (\Transaction {..} -> timestamp) txs + let net = st.config.store.net + let url = st.config.priceHistoryURL + let session = st.session + let logger = st.config.logger + rates <- map (.price) <$> (getRates logger net session url code times) + let hs = zipWith (convert cur aaddrs) txs (rates <> repeat 0.0) + streamEncoding $ toEncoding hs + where + is_newer + (Just BlockData {height = bh}) + TxRef {block = BlockRef {height = th}} = + bh <= th + is_newer Nothing TxRef {} = True + is_newer _ _ = undefined + get_addr = (.balance.address) + get_transaction TxRef {txid = h} = + C.getTransaction st.query h + convert cur addrs tx rate = + let ins = tx.inputs + outs = tx.outputs + fins = filter (input_addr addrs) ins + fouts = filter (output_addr addrs) outs + vin = fromIntegral . sum $ map (.value) fins + vout = fromIntegral . sum $ map (.value) fouts + fee = tx.fee + v = vout - vin + t = tx.timestamp + h = txHash $ transactionData tx + in toBinfoHistory v t rate cur fee h + input_addr addrs' StoreInput {address = Just a} = + a `HashSet.member` addrs' + input_addr _ _ = False + output_addr addrs' StoreOutput {address = Just a} = + a `HashSet.member` addrs' + output_addr _ _ = False + get_dates = do + BinfoDate start <- requireParam st req parseBinfoDate "start" + BinfoDate end' <- requireParam st req parseBinfoDate "end" + let end = end' + 24 * 60 * 60 + let ch = st.config.store.chain + startM <- C.blockAtOrAfter st.query ch start + endM <- C.blockAtOrBefore st.query ch end + return (startM, endM) + conduits xpubs addrs endM = + map (uncurry (xpub_c endM)) xpubs + <> map (addr_c endM) (HashSet.toList addrs) + lim endM = + Limits + { limit = 16, + offset = 0, + start = AtBlock . (.height) <$> endM + } + addr_c endM a = + streamThings (st.query.getAddressTxs a) (Just (.txid)) (lim endM) + xpub_c endM x bs = + streamThings (st.query.xPubTxs x bs) (Just (.txid)) (lim endM) + +-- | Currency code in the @currency@ parameter, USD by default, in any case, +-- and its latest price. A currency that the price service does not list is +-- refused. Until the server has prices, which it may never have if the +-- service cannot be reached, every currency has a price of zero, rather than +-- every request being refused. +getPrice :: WebState -> Req -> IO (Text, BinfoTicker) +getPrice st req = do + prices <- readTVarIO st.ticker + let known c + | HashMap.null prices = Just (c, def) + | otherwise = (c,) <$> HashMap.lookup c prices + paramOr req (known . T.toUpper) "currency" ("USD", fromMaybe def (HashMap.lookup "USD" prices)) + +-- | Symbol of the currency in the @currency@ parameter. +getSymbol :: WebState -> Req -> IO BinfoSymbol +getSymbol st req = uncurry binfoTickerToSymbol <$> getPrice st req + +-- | Handler for @GET \/blockchain\/blocks\/:milliseconds@: the blocks of the day +-- before a time in milliseconds, as Blockchain.info. +handleBinfoBlocksDay :: WebState -> Req -> IO Response +handleBinfoBlocksDay st req = + withMetrics st (.binfoBlock) $ do + t <- min h . (`div` 1000) <$> captureWith req readNum "milliseconds" + let ch = st.config.store.chain + m <- C.blockAtOrBefore st.query ch t + bs <- go (d t) m + streamEncoding $ toEncoding $ map toBinfoBlockInfo bs + where + h = fromIntegral (maxBound :: H.Timestamp) + d = subtract (24 * 3600) + go _ Nothing = return [] + go t (Just b) + | b.header.timestamp <= fromIntegral t = + return [] + | otherwise = do + b' <- st.query.getBlock b.header.prev + (b :) <$> go t b' + +-- | Handler for @GET\/POST \/blockchain\/multiaddr@: balances and transactions of +-- addresses and xpubs, as Blockchain.info. +handleMultiAddr :: WebState -> Req -> IO Response +handleMultiAddr st req = + withMetrics st (.binfoMultiaddr) $ do + (addrs', _, saddrs, sxpubs, xspecs) <- get_addrs + numtxid <- getNumTxId req + cashaddr <- getCashAddr req + local' <- getSymbol st req + offset <- getBinfoOffset st req + n <- getBinfoCount st req "n" + prune <- get_prune + fltr <- get_filter + xbals <- (getXBals st.query xspecs) + xtxns <- get_xpub_tx_count xbals xspecs + let sxbals = only_show_xbals sxpubs xbals + xabals = compute_xabals xbals + addrs = addrs' `HashSet.difference` HashMap.keysSet xabals + abals <- get_abals addrs + let sxspecs = only_show_xspecs sxpubs xspecs + sxabals = compute_xabals sxbals + sabals = only_show_abals saddrs abals + sallbals = sabals <> sxabals + sbal = compute_bal sallbals + allbals = abals <> xabals + abook = compute_abook addrs xbals + sxaddrs = compute_xaddrs sxbals + salladdrs = saddrs <> sxaddrs + bal = compute_bal allbals + ibal = fromIntegral sbal + ftxs <- + runConduit $ + getBinfoTxs + st.query + (pageFor offset n) + xbals + abook + sxspecs + saddrs + salladdrs + fltr + numtxid + prune + ibal + .| (dropC offset >> takeC n .| sinkList) + -- counted without reading the transactions, which takes seconds for + -- xpubs with tens of thousands of them: one xpub has its own count, from + -- the cache when it is cached; for several xpubs and addresses, the + -- database counts the distinct transactions of all their addresses + ntx <- case (HashSet.toList sxspecs, HashSet.null saddrs) of + ([x], True) -> return (HashMap.findWithDefault 0 x xtxns) + _ -> fromIntegral <$> st.direct.getAddressesTxCount (HashSet.toList salladdrs) + nfiltered <- case fltr of + BinfoFilterAll -> return ntx + _ -> + runConduit $ + getBinfoTxs + st.query + 1000 + xbals + abook + sxspecs + saddrs + salladdrs + fltr + numtxid + prune + ibal + .| lengthC + let net = st.config.store.net + let ctx = st.config.store.ctx + best <- get_best_block + peers <- get_peers + let baddrs = toBinfoAddrs sabals sxbals xtxns + abaddrs = toBinfoAddrs abals xbals xtxns + recv = sum $ map (.received) abaddrs + sent' = sum $ map (.sent) abaddrs + wallet = + BinfoWallet + { balance = bal, + txs = ntx, + filtered = nfiltered, + received = recv, + sent = sent' + } + coin = netBinfoSymbol net + let block = + BinfoBlockInfo + { hash = H.headerHash best.header, + height = best.height, + timestamp = best.header.timestamp, + index = best.height + } + let info = + BinfoInfo + { connected = peers, + conversion = 100 * 1000 * 1000, + fiat = local', + crypto = coin, + head = block + } + let multiaddr = + BinfoMultiAddr + { addresses = baddrs, + wallet = wallet, + txs = ftxs, + info = info, + recommendFee = True, + cashAddr = cashaddr + } + streamEncoding $ marshalEncoding (net, ctx) multiaddr + where + get_xpub_tx_count xbals = + fmap HashMap.fromList + . mapM + ( \x -> + (x,) + . fromIntegral + <$> st.query.xPubTxCount x (xBals x xbals) + ) + . HashSet.toList + get_filter = paramOr req parseBinfoFilter "filter" BinfoFilterAll + get_best_block = + st.query.getBestBlock >>= \case + Nothing -> raise st ThingNotFound + Just bh -> + st.query.getBlock bh >>= \case + Nothing -> raise st ThingNotFound + Just b -> return b + get_prune = do + noCompact <- paramOr req readBool "no_compact" False + not <$> paramOr req readBool "noCompact" noCompact + only_show_xbals sxpubs = + HashMap.filterWithKey (\k _ -> k.key `HashSet.member` sxpubs) + only_show_xspecs sxpubs = + HashSet.filter (\k -> k.key `HashSet.member` sxpubs) + only_show_abals saddrs = + HashMap.filterWithKey (\k _ -> k `HashSet.member` saddrs) + addr (BinfoAddr a) = Just a + addr (BinfoXpub _) = Nothing + xpub (BinfoXpub x) = Just x + xpub (BinfoAddr _) = Nothing + get_addrs = do + (xspecs, addrs) <- getBinfoActive st req + sh <- getBinfoAddrsParam st req "onlyShow" + let xpubs = HashSet.map (.key) xspecs + actives = + HashSet.map BinfoAddr addrs + <> HashSet.map BinfoXpub xpubs + sh' = if HashSet.null sh then actives else sh + saddrs = HashSet.fromList $ mapMaybe addr $ HashSet.toList sh' + sxpubs = HashSet.fromList $ mapMaybe xpub $ HashSet.toList sh' + return (addrs, xpubs, saddrs, sxpubs, xspecs) + get_abals = + let f b = (b.address, b) + g = HashMap.fromList . map f + in fmap g . st.query.getBalances . HashSet.toList + get_peers = do + ps <- getPeersInformation st.config.store.peerMgr + return (fromIntegral (length ps)) + compute_xabals = + let f b = (b.balance.address, b.balance) + in HashMap.fromList . concatMap (map f) . HashMap.elems + compute_bal = + let f b = b.confirmed + b.unconfirmed + in sum . map f . HashMap.elems + compute_abook addrs xbals = + let f xs xb = + let a = xb.balance.address + e = error "lions and tigers and bears" + s = toSoft (listToPath xb.path) + in (a, Just (BinfoXPubPath xs.key (fromMaybe e s))) + amap = + HashMap.map (const Nothing) $ + HashSet.toMap addrs + xmap = + HashMap.fromList + . concatMap (uncurry (map . f)) + $ HashMap.toList xbals + in amap <> xmap + compute_xaddrs = + let f = map (.balance.address) + in HashSet.fromList . concatMap f . HashMap.elems + +-- | Number of items requested in a parameter, within the limits. +getBinfoCount :: WebState -> Req -> Text -> IO Int +getBinfoCount st req str = do + let d = st.config.limits.defItemCount + let x = st.config.limits.maxFullItemCount + i <- fromIntegral <$> paramOr req readNat str (fromIntegral d) + return (fromIntegral (if x == 0 then i else min x i) :: Int) + +-- | Offset requested in the @offset@ parameter. Responds with an error if above the maximum. +getBinfoOffset :: + WebState -> + Req -> + IO Int +getBinfoOffset st req = do + let x = st.config.limits.maxOffset + o <- fromIntegral <$> paramOr req readNat "offset" 0 + when (o > x) $ + raise st $ + UserError $ + "offset exceeded: " <> show o <> " > " <> show x + return (fromIntegral o :: Int) + +-- | Handler for @GET \/blockchain\/rawaddr\/:addr@: balance and transactions of an +-- address or xpub, as Blockchain.info; also at @\/blockchain\/address\/:addr@ +-- and @\/blockchain\/xpub\/:addr@. +handleRawAddr :: WebState -> Req -> IO Response +handleRawAddr st req = + withMetrics st (.binfoAddressRaw) $ + getBinfoAddr st req "addr" >>= \case + BinfoAddr addr -> do_addr addr + BinfoXpub xpub -> do_xpub xpub + where + do_xpub xpub = do + numtxid <- getNumTxId req + derive <- paramOr req (readDerive st.config.store.net) "derive" DeriveNormal + let xspec = XPubSpec xpub derive + n <- getBinfoCount st req "limit" + off <- getBinfoOffset st req + xbals <- (getXBals st.query (HashSet.singleton xspec)) + checkDerive st xspec (xBals xspec xbals) + let net = st.config.store.net + let summary = xPubSummary xspec (xBals xspec xbals) + abook = compute_abook xpub (xBals xspec xbals) + xspecs = HashSet.singleton xspec + saddrs = HashSet.empty + baddrs = HashMap.keysSet abook + bfilter = BinfoFilterAll + amnt = summary.confirmed + summary.unconfirmed + txs <- + runConduit $ + getBinfoTxs + st.query + (pageFor off n) + xbals + abook + xspecs + saddrs + baddrs + bfilter + numtxid + False + (fromIntegral amnt) + .| (dropC off >> takeC n .| sinkList) + -- n_tx is every transaction of the xpub, as for an address, not the + -- number on this page + ntx <- st.query.xPubTxCount xspec (xBals xspec xbals) + let ra = + BinfoRawAddr + { address = BinfoXpub xpub, + balance = amnt, + ntx = fromIntegral ntx, + utxo = summary.utxo, + received = summary.received, + sent = fromIntegral summary.received - fromIntegral amnt, + txs = txs + } + let ctx = st.config.store.ctx + streamEncoding $ marshalEncoding (net, ctx) ra + compute_abook xpub xbals = + let f xb = + let a = xb.balance.address + e = error "black hole swallows all your code" + s = toSoft $ listToPath xb.path + m = fromMaybe e s + in (a, Just (BinfoXPubPath xpub m)) + in HashMap.fromList $ map f xbals + do_addr addr = do + numtxid <- getNumTxId req + n <- getBinfoCount st req "limit" + off <- getBinfoOffset st req + bal <- fromMaybe (zeroBalance addr) <$> st.query.getBalance addr + let net = st.config.store.net + let abook = HashMap.singleton addr Nothing + xspecs = HashSet.empty + saddrs = HashSet.singleton addr + bfilter = BinfoFilterAll + balance = bal.confirmed + bal.unconfirmed + txs <- + runConduit $ + getBinfoTxs + st.query + (pageFor off n) + HashMap.empty + abook + xspecs + saddrs + saddrs + bfilter + numtxid + False + (fromIntegral balance) + .| (dropC off >> takeC n .| sinkList) + let ra = + BinfoRawAddr + { address = BinfoAddr addr, + balance, + ntx = bal.txs, + utxo = bal.utxo, + received = bal.received, + sent = fromIntegral bal.received - fromIntegral balance, + txs + } + let ctx = st.config.store.ctx + streamEncoding $ marshalEncoding (net, ctx) ra + +-- | Handler for @GET \/blockchain\/q\/getreceivedbyaddress\/:addr@: total received by an address. +handleBinfoReceived :: WebState -> Req -> IO Response +handleBinfoReceived st req = + withMetrics st (.binfoQgetreceivedbyaddress) $ do + a <- getAddress st =<< capture req "addr" + b <- fromMaybe (zeroBalance a) <$> st.query.getBalance a + textResponse $ cs $ show b.received + +-- | Handler for @GET \/blockchain\/q\/getsentbyaddress\/:addr@: total sent by an address. +handleBinfoSent :: WebState -> Req -> IO Response +handleBinfoSent st req = + withMetrics st (.binfoQgetsentbyaddress) $ do + a <- getAddress st =<< capture req "addr" + b <- fromMaybe (zeroBalance a) <$> st.query.getBalance a + textResponse $ cs $ show $ b.received - b.confirmed - b.unconfirmed + +-- | Handler for @GET \/blockchain\/q\/addressbalance\/:addr@: balance of an address. +handleBinfoAddrBalance :: WebState -> Req -> IO Response +handleBinfoAddrBalance st req = + withMetrics st (.binfoQaddressbalance) $ do + a <- getAddress st =<< capture req "addr" + b <- fromMaybe (zeroBalance a) <$> st.query.getBalance a + textResponse $ cs $ show $ b.confirmed + b.unconfirmed + +-- | Handler for @GET \/blockchain\/q\/addressfirstseen\/:addr@: time of the first +-- block with a transaction of an address. +handleFirstSeen :: WebState -> Req -> IO Response +handleFirstSeen st req = + withMetrics st (.binfoQaddressfirstseen) $ do + a <- getAddress st =<< capture req "addr" + let ch = st.config.store.chain + bb <- chainGetBest ch + let top = bb.height + bot = 0 + i <- go ch bb a bot top + textResponse $ cs $ show i + where + go ch bb a bot top = do + let mid = bot + (top - bot) `div` 2 + n = top - bot < 2 + x <- hasone a bot + y <- hasone a mid + z <- hasone a top + if + | x -> getblocktime ch bb bot + | n -> getblocktime ch bb top + | y -> go ch bb a bot mid + | z -> go ch bb a mid top + | otherwise -> return 0 + getblocktime ch bb h = + (chainGetAncestor ch h bb) >>= \case + Just b -> return b.header.timestamp + Nothing -> do + let logger = st.config.logger + logError logger $ + "Could not get ancestor at height " + <> cs (show h) + <> " for block " + <> H.blockHashToHex (H.headerHash bb.header) + error "Block ancestor retreival error" + hasone a h = do + let l = Limits 1 0 (Just (AtBlock h)) + not . null <$> st.query.getAddressTxs a l + +-- | Handler for @GET\/POST \/blockchain\/balance@: short balances of addresses and xpubs, as Blockchain.info. +handleShortBal :: WebState -> Req -> IO Response +handleShortBal st req = + withMetrics st (.binfoBalance) $ do + (xspecs, addrs) <- getBinfoActive st req + cashaddr <- getCashAddr req + let net = st.config.store.net + abals <- catMaybes <$> mapM (getabal net cashaddr) (HashSet.toList addrs) + xbals <- mapM (getxbal net) (HashSet.toList xspecs) + let res = HashMap.fromList (abals <> xbals) + streamEncoding $ toEncoding res + where + shorten bal = + BinfoShortBal + { final = bal.confirmed + bal.unconfirmed, + ntx = bal.txs, + received = bal.received + } + getabal net cashaddr a = + let net' = + if + | cashaddr -> net + | net == bch -> btc + | net == bchTest -> btcTest + | net == bchTest4 -> btcTest + | otherwise -> net + in case addrToText net' a of + Nothing -> return Nothing + Just a' -> + st.query.getBalance a >>= \case + Nothing -> return $ Just (a', shorten (zeroBalance a)) + Just b -> return $ Just (a', shorten b) + getxbal net xpub = do + xbals <- st.query.xPubBals xpub + ntx <- fromIntegral <$> st.query.xPubTxCount xpub xbals + let val = sum $ map (.balance.confirmed) xbals + zro = sum $ map (.balance.unconfirmed) xbals + exs = [x | x@XPubBal {path = 0 : _} <- xbals] + final = val + zro + received = sum $ map (.balance.received) exs + sbl = BinfoShortBal {final, ntx, received} + let ctx = st.config.store.ctx + return (xPubExport net ctx xpub.key, sbl) + +-- | Whether to respond with hex (@format=hex@). +getBinfoHex :: Req -> IO Bool +getBinfoHex req = paramOr req format "format" False + where + format "hex" = Just True + format "json" = Just False + format _ = Nothing + +-- | Handler for @GET \/blockchain\/block-height\/:height@: the blocks at a height, as Blockchain.info. +handleBinfoBlockHeight :: WebState -> Req -> IO Response +handleBinfoBlockHeight st req = + withMetrics st (.binfoBlockHeight) $ do + numtxid <- getNumTxId req + height <- captureWith req readNum "height" + bs <- fmap catMaybes $ st.query.getBlocksAtHeight height >>= mapM (st.query.getBlock) + ns <- fmap catMaybes $ st.query.getBlocksAtHeight (height + 1) >>= mapM (st.query.getBlock) + is <- mapM (get_binfo_blocks numtxid ns) bs + let net = st.config.store.net + let ctx = st.config.store.ctx + streamEncoding $ marshalEncoding (net, ctx) is + where + get_binfo_blocks numtxid ns b = do + txs <- catMaybes <$> C.getTransactions st.query b.txs + let h x = H.headerHash x.header + nbs = [h n | n <- ns, n.header.prev == h b] + bts = map (toBinfoTxSimple numtxid) txs + return $ toBinfoBlock b bts nbs + +-- | Handler for @GET \/blockchain\/latestblock@: the best block, as Blockchain.info. +handleBinfoLatest :: WebState -> Req -> IO Response +handleBinfoLatest st req = + withMetrics st (.binfoBlockLatest) $ do + numtxid <- getNumTxId req + b <- (bestBlock st.query) >>= maybe (raise st ThingNotFound) return + streamEncoding $ + toEncoding + BinfoHeader + { hash = H.headerHash b.header, + timestamp = b.header.timestamp, + index = b.height, + height = b.height, + txids = map (encodeBinfoTxId numtxid) b.txs + } + +-- | Handler for @GET \/blockchain\/rawblock\/:block@: a block with its transactions, as Blockchain.info. +handleBinfoBlock :: WebState -> Req -> IO Response +handleBinfoBlock st req = + withMetrics st (.binfoBlockRaw) $ do + numtxid <- getNumTxId req + hex <- getBinfoHex req + captureWith req parseBinfoBlockId "block" >>= \case + BinfoBlockHash bh -> go numtxid hex bh + BinfoBlockIndex i -> + st.query.getBlocksAtHeight i >>= \case + [] -> raise st ThingNotFound + bh : _ -> go numtxid hex bh + where + go numtxid hex bh = do + b <- maybe (raise st ThingNotFound) return =<< st.query.getBlock bh + txs <- catMaybes <$> C.getTransactions st.query b.txs + nhs <- fmap catMaybes $ st.query.getBlocksAtHeight (b.height + 1) >>= mapM (st.query.getBlock) + let h x = H.headerHash x.header + nxt = [h n | n <- nhs, n.header.prev == h b] + if hex + then do + let x = H.Block b.header (map transactionData txs) + textResponse . encodeHexLazy . runPutL $ serialize x + else do + let bts = map (toBinfoTxSimple numtxid) txs + y = toBinfoBlock b bts nxt + let net = st.config.store.net + let ctx = st.config.store.ctx + streamEncoding $ marshalEncoding (net, ctx) y + +-- | Transaction by hash or short number. Fails with 'TxIndexConflict' if a short number matches several. +getBinfoTx :: + WebState -> + BinfoTxId -> + IO (Either Except Transaction) +getBinfoTx st txid = do + tx <- case txid of + BinfoTxIdHash h -> maybeToList <$> C.getTransaction st.query h + BinfoTxIdIndex i -> C.getNumTransaction st.query i + case tx of + [t] -> return $ Right t + [] -> return $ Left ThingNotFound + ts -> + let tids = map (txHash . transactionData) ts + in return $ Left (TxIndexConflict tids) + +-- | Handler for @GET \/blockchain\/rawtx\/:txid@: a transaction, as Blockchain.info. +handleBinfoTx :: WebState -> Req -> IO Response +handleBinfoTx st req = + withMetrics st (.binfoTxRaw) $ do + numtxid <- getNumTxId req + hex <- getBinfoHex req + txid <- captureWith req parseBinfoTxId "txid" + tx <- + getBinfoTx st txid >>= \case + Right t -> return t + Left e -> raise st e + if hex then hx tx else js numtxid tx + where + js numtxid t = do + let net = st.config.store.net + let ctx = st.config.store.ctx + streamEncoding $ marshalEncoding (net, ctx) $ toBinfoTxSimple numtxid t + hx t = do + textResponse . encodeHexLazy . runPutL . serialize $ transactionData t + +-- | Handler for @GET \/blockchain\/q\/txtotalbtcoutput\/:txid@: total value of the outputs of a transaction. +handleBinfoTotalOut :: WebState -> Req -> IO Response +handleBinfoTotalOut st req = + withMetrics st (.binfoQtxtotalbtcoutput) $ do + txid <- captureWith req parseBinfoTxId "txid" + tx <- + getBinfoTx st txid >>= \case + Right t -> return t + Left e -> raise st e + textResponse $ cs $ show $ sum $ map (.value) tx.outputs + +-- | Handler for @GET \/blockchain\/q\/txfee\/:txid@: fee of a transaction. +handleBinfoTxFees :: WebState -> Req -> IO Response +handleBinfoTxFees st req = + withMetrics st (.binfoQtxfee) $ do + txid <- captureWith req parseBinfoTxId "txid" + tx <- + getBinfoTx st txid >>= \case + Right t -> return t + Left e -> raise st e + let i = sum $ map (.value) $ filter f tx.inputs + o = sum $ map (.value) tx.outputs + textResponse . cs . show $ i - o + where + f StoreInput {} = True + f StoreCoinbase {} = False + +-- | Handler for @GET \/blockchain\/q\/txresult\/:txid\/:addr@: net amount that a transaction sends to an address. +handleBinfoTxResult :: WebState -> Req -> IO Response +handleBinfoTxResult st req = + withMetrics st (.binfoQtxresult) $ do + txid <- captureWith req parseBinfoTxId "txid" + addr <- getAddress st =<< capture req "addr" + tx <- + getBinfoTx st txid >>= \case + Right t -> return t + Left e -> raise st e + let i = toInteger $ sum $ map (.value) $ filter (f addr) tx.inputs + o = toInteger $ sum $ map (.value) $ filter (g addr) tx.outputs + textResponse $ cs $ show $ o - i + where + f addr StoreInput {address = Just a} = a == addr + f _ _ = False + g addr StoreOutput {address = Just a} = a == addr + g _ _ = False + +-- | Handler for @GET \/blockchain\/q\/txtotalbtcinput\/:txid@: total value of the inputs of a transaction. +handleBinfoTotalInput :: WebState -> Req -> IO Response +handleBinfoTotalInput st req = + withMetrics st (.binfoQtxtotalbtcinput) $ do + txid <- captureWith req parseBinfoTxId "txid" + tx <- + getBinfoTx st txid >>= \case + Right t -> return t + Left e -> raise st e + textResponse $ cs $ show $ sum $ map (.value) $ filter f $ tx.inputs + where + f StoreInput {} = True + f StoreCoinbase {} = False + +-- | Handler for @GET \/blockchain\/unconfirmed-transactions@: mempool transactions, as Blockchain.info. +handleBinfoMempool :: WebState -> Req -> IO Response +handleBinfoMempool st req = + withMetrics st (.binfoMempool) $ do + numtxid <- getNumTxId req + offset <- getBinfoOffset st req + n <- getBinfoCount st req "limit" + -- a limit of 0 would mean no limit to st.query.getMempoolPage + txids <- + if n <= 0 + then return [] + else + map snd + <$> st.query.getMempoolPage (Limits (fromIntegral n) (fromIntegral offset) Nothing) + txs <- catMaybes <$> C.getTransactions st.query txids + let net = st.config.store.net + let mem = BinfoMempool $ map (toBinfoTxSimple numtxid) txs + let ctx = st.config.store.ctx + streamEncoding $ marshalEncoding (net, ctx) mem + +-- | Handler for @GET \/blockchain\/q\/getblockcount@: height of the best header. +handleBinfoGetBlockCount :: WebState -> Req -> IO Response +handleBinfoGetBlockCount st _ = + withMetrics st (.binfoQgetblockcount) $ do + let ch = st.config.store.chain + bn <- chainGetBest ch + textResponse $ TL.pack $ show bn.height + +-- | Handler for @GET \/blockchain\/q\/latesthash@: hash of the best header. +handleBinfoLatestHash :: WebState -> Req -> IO Response +handleBinfoLatestHash st _ = + withMetrics st (.binfoQlatesthash) $ do + let ch = st.config.store.chain + bn <- chainGetBest ch + textResponse $ TL.fromStrict $ H.blockHashToHex $ H.headerHash bn.header + +-- | Handler for @GET \/blockchain\/q\/bcperblock@: block subsidy at the next height. +handleBinfoSubsidy :: WebState -> Req -> IO Response +handleBinfoSubsidy st _ = + withMetrics st (.binfoQbcperblock) $ do + let ch = st.config.store.chain + let net = st.config.store.net + bn <- chainGetBest ch + textResponse $ + cs $ + show $ + (/ (100 * 1000 * 1000 :: Double)) $ + fromIntegral $ + H.computeSubsidy net (bn.height + 1) + +-- | Handler for @GET \/blockchain\/q\/addresstohash\/:addr@: hash160 of an address in hex. +handleBinfoAddrToHash :: WebState -> Req -> IO Response +handleBinfoAddrToHash st req = + withMetrics st (.binfoQaddresstohash) $ do + addr <- getAddress st =<< capture req "addr" + if + | Just h <- addressHash160 addr -> + textResponse $ encodeHexLazy $ runPutL $ serialize h + | Just h <- addressHash256 addr -> + textResponse $ encodeHexLazy $ runPutL $ serialize h + | otherwise -> + textResponse "" + +-- | Handler for @GET \/blockchain\/q\/hashtoaddress\/:hash@: pay-to-public-key-hash address of a hash160. +handleBinfoHashToAddr :: WebState -> Req -> IO Response +handleBinfoHashToAddr st req = + withMetrics st (.binfoQhashtoaddress) $ do + bs <- maybe next return . decodeHex =<< capture req "hash" + let net = st.config.store.net + hash <- either (const next) return $ decode bs + addr <- maybe next return $ addrToText net $ PubKeyAddress hash + textResponse $ TL.fromStrict addr + +-- | Handler for @GET \/blockchain\/q\/addrpubkey\/:pubkey@: address of a public key. +handleBinfoAddrPubkey :: WebState -> Req -> IO Response +handleBinfoAddrPubkey st req = + withMetrics st (.binfoQaddrpubkey) $ do + hex <- capture req "pubkey" + let ctx = st.config.store.ctx + pubkey <- + maybe next (return . pubKeyAddr ctx) $ + eitherToMaybe . unmarshal ctx =<< decodeHex hex + let net = st.config.store.net + case addrToText net pubkey of + Nothing -> raise st ThingNotFound + Just a -> textResponse $ TL.fromStrict a + +-- | Handler for @GET \/blockchain\/q\/pubkeyaddr\/:addr@: public key of an +-- address, found in a transaction input that spends from it. +handleBinfoPubKeyAddr :: WebState -> Req -> IO Response +handleBinfoPubKeyAddr st req = + withMetrics st (.binfoQpubkeyaddr) $ do + addr <- getAddress st =<< capture req "addr" + mi <- strm addr + i <- case mi of + Nothing -> raise st ThingNotFound + Just i -> return i + pk <- case extr addr i of + Left e -> raise st $ UserError e + Right t -> return t + textResponse $ encodeHexLazy $ L.fromStrict pk + where + strm addr = do + runConduit $ do + let l = Limits {limit = 8, offset = 0, start = Nothing} + streamThings (st.query.getAddressTxs addr) (Just (.txid)) l + .| concatMapMC (C.getTransaction st.query . (.txid)) + .| concatMapC (filter (inp addr) . (.inputs)) + .| headC + inp addr StoreInput {address = Just a} = a == addr + inp _ _ = False + extr addr StoreInput {script, pkscript, witness} = do + Script sig <- decode script + Script pks <- decode pkscript + case addr of + PubKeyAddress {} -> + case sig of + [OP_PUSHDATA _ _, OP_PUSHDATA pub _] -> + Right pub + [OP_PUSHDATA _ _] -> + case pks of + [OP_PUSHDATA pub _, OP_CHECKSIG] -> + Right pub + _ -> Left "Could not parse scriptPubKey" + _ -> Left "Could not parse scriptSig" + WitnessPubKeyAddress {} -> + case witness of + [_, pub] -> return pub + _ -> Left "Could not parse scriptPubKey" + _ -> Left "Address does not have public key" + extr _ _ = Left "Incorrect input type" + +-- | Handler for @GET \/blockchain\/q\/hashpubkey\/:pubkey@: hash160 of a public key in hex. +handleBinfoHashPubkey :: WebState -> Req -> IO Response +handleBinfoHashPubkey st req = + withMetrics st (.binfoQhashpubkey) $ do + let ctx = st.config.store.ctx + pkm <- + fmap + (eitherToMaybe . unmarshal ctx <=< decodeHex) + (capture req "pubkey") + addr <- case pkm of + Nothing -> raise st $ UserError "Could not decode public key" + Just pk -> return $ pubKeyAddr ctx pk + if + | Just h <- addressHash160 addr -> + textResponse $ encodeHexLazy $ runPutL $ serialize h + | Just h <- addressHash256 addr -> + textResponse $ encodeHexLazy $ runPutL $ serialize h + | otherwise -> + textResponse "" + +-- GET Network Information -- + +-- | Handler for @GET \/peers@: connected peers. +handlePeers :: + WebState -> + GetPeers -> + IO [PeerInfo] +handlePeers st _ = + withMetrics st (.peers) $ do + getPeersInformation =<< pure st.config.store.peerMgr + +-- | Obtain information about connected peers from peer manager process. +getPeersInformation :: + PeerMgr -> IO [PeerInfo] +getPeersInformation mgr = + mapMaybe toInfo <$> (getPeers mgr) + where + toInfo op = do + ver <- op.version + return + PeerInfo + { userAgent = ver.userAgent.get, + address = show op.address, + -- Signed, as the peer sent it. See 'PeerInfo'. + version = ver.version, + services = ver.services, + relay = ver.relay + } + +-- | The route of @GET \/health@. Its status says in one number what a load +-- balancer needs to know: +-- +-- * 200: every check passes; +-- +-- * 203: every check passes, but Redis does not answer, so the store +-- answers from its own database and mempool alone; +-- +-- * 503: a check fails. +-- +-- = Why 203 for a store without its Redis +-- +-- Such a store is not broken: its answers are right for what it has seen. A +-- load balancer should go on sending it requests, which it does for any +-- status in the 200s, so the status cannot be an error. But the answers are +-- no longer those of the fleet: they do not come from the copy that the +-- stores share. That is what 203, Non-Authoritative Information, says of a +-- response, and a monitor that expects exactly 200 will notice it. 207 was +-- the other candidate, for a body with a status for each part; it promises +-- a format that this body does not have. The response also names what is +-- missing in a @Haskoin-Degraded@ header. +-- +-- = The check of Redis in the body +-- +-- The body of a store that has a cache has one more check than the others, +-- 'Haskoin.Store.Data.redis', which says whether Redis answers. It does not +-- count towards the @ok@ of the whole, which stays the answer to "is this +-- store fit to serve". +pathHealth :: WebState -> Route +pathHealth st = + route (renderStdMethod (resourceMethod proxy)) (capturePath proxy) ["pretty"] $ \req -> do + proto <- serialAs req False + h <- handleHealth st GetHealth + let (status, extra) + | not (isOK h) = (status503, [("Retry-After", "5")]) + | h.redis == Just False = (status203, [("Haskoin-Degraded", "redis")]) + | otherwise = (status200, []) + return $ + responseLBS status ((hContentType, serialType proto) : extra) (protoSerial proto toEncoding toJSON h) + where + proxy = Proxy :: Proxy GetHealth + +-- | Handler for @GET \/health@: health of the store. +handleHealth :: + WebState -> + GetHealth -> + IO HealthCheck +handleHealth st _ = + withMetrics st (.health) $ do + h <- readTVarIO st.health + up <- readTVarIO st.cacheUp + -- a store without a cache has no Redis to be without + let HealthCheck {blocks, lastBlock, lastTx, pendingTxs, peers, network, version, time} = h + let shares = void st.config.store.cache <|> void st.config.store.fleet + return HealthCheck {redis = up <$ shares, ..} + +-- | Heights of the best header and best block, and the maximum lag allowed. +blockHealthCheck :: WebConfig -> IO BlockHealth +blockHealthCheck cfg = do + let ch = cfg.store.chain + db = cfg.store.db + headers <- (.height) <$> chainGetBest ch + blocks <- + Q.getBestBlock db >>= \case + Nothing -> return 0 + Just h -> maybe 0 (.height) <$> Q.getBlock db h + return + BlockHealth + { headers, + blocks, + max = fromIntegral cfg.maxLaggingBlocks + } + +-- | Age of the best header and the maximum allowed. +lastBlockHealthCheck :: Chain -> WebLimits -> IO TimeHealth +lastBlockHealthCheck ch WebLimits {blockTimeout} = do + n <- round <$> getPOSIXTime + t <- fromIntegral . (.header.timestamp) <$> (chainGetBest ch) + return + TimeHealth + { age = n - t, + max = fromIntegral blockTimeout + } + +-- | Age of the newest mempool transaction or best header, and the maximum allowed. +lastTxHealthCheck :: WebConfig -> IO TimeHealth +lastTxHealthCheck WebConfig {noMempool, store = store', limits} = do + n <- round <$> getPOSIXTime + b <- fromIntegral . (.header.timestamp) <$> (chainGetBest ch) + t <- + Q.getMempoolPage store'.db (Limits 1 0 Nothing) >>= \case + t : _ -> + let x = fromIntegral $ fst t + in return $ max x b + [] -> return b + return + TimeHealth + { age = n - t, + max = fromIntegral to + } + where + ch = store'.chain + to = + if noMempool + then limits.blockTimeout + else limits.txTimeout + +-- | Transactions waiting to be imported and the maximum allowed. +pendingTxsHealthCheck :: WebConfig -> IO MaxHealth +pendingTxsHealthCheck cfg = do + n <- blockStorePendingTxs cfg.store.block + return + MaxHealth + { max = fromIntegral cfg.maxPendingTxs, + count = fromIntegral n + } + +-- | Online peers and the minimum required. +peerHealthCheck :: WebConfig -> IO CountHealth +peerHealthCheck cfg = do + count <- fromIntegral . length <$> (getPeers cfg.store.peerMgr) + return CountHealth {min = fromIntegral cfg.minPeers, count} + +-- | Run every health check. +healthCheck :: WebConfig -> IO HealthCheck +healthCheck cfg = do + blocks <- blockHealthCheck cfg + lastBlock <- lastBlockHealthCheck cfg.store.chain cfg.limits + lastTx <- lastTxHealthCheck cfg + pendingTxs <- pendingTxsHealthCheck cfg + peers <- peerHealthCheck cfg + time <- round <$> getPOSIXTime + return + HealthCheck + { network = cfg.store.net.name, + version = cfg.version, + -- filled in when the check is served, from what the last request + -- or ping found + redis = Nothing, + .. + } + +-- | Handler for @GET \/dbstats@: RocksDB memory use and statistics, as text. +handleDbStats :: WebState -> Req -> IO Response +handleDbStats st _ = + withMetrics st (.db) $ do + let db = st.config.store.db.db + memory <- (memoryReport db) + statsM <- (getProperty db Stats) + textResponse . cs $ memory <> maybe "Could not get stats" cs statsM + +----------------------- +-- Parameter Parsing -- +----------------------- + +-- | Returns @Nothing@ if the parameter is not supplied. Raises an exception on +-- parse failure. +paramOptional :: forall a. (Param a) => WebState -> Req -> IO (Maybe a) +paramOptional st req = do + let net = st.config.store.net + let ctx = st.config.store.ctx + param req label >>= \case + Nothing -> return Nothing -- Parameter was not supplied + Just t -> Just <$> readParam (parseParam net ctx . T.splitOn ",") label t + where + label = proxyLabel (Proxy :: Proxy a) + +-- | Raises an exception if the parameter is not supplied +paramRequired :: forall a. (Param a) => WebState -> Req -> IO a +paramRequired st req = maybe (raise st err) return =<< paramOptional st req + where + label = T.unpack (proxyLabel (Proxy :: Proxy a)) + err = UserError $ "Missing parameter " <> label + +-- | Returns the default value of a parameter if it is not supplied. Raises an +-- exception on parse failure. +paramDef :: (Default a, Param a) => WebState -> Req -> IO a +paramDef st req = fromMaybe def <$> paramOptional st req + +-- | Does not raise exceptions. Passes the request to the next route ('next') if the parameter is +-- not supplied or if parsing fails. +paramCapture :: forall a. (Param a) => WebState -> Req -> IO a +paramCapture st req = do + let net = st.config.store.net + let ctx = st.config.store.ctx + p <- capture req label + maybe next return (parseParam net ctx (T.splitOn "," p)) + where + label = proxyLabel (Proxy :: Proxy a) + +-- | Read the transaction that a request carries in its body. +parseTxBody :: WebState -> Req -> IO Tx +parseTxBody st req = do + let net = st.config.store.net + case decodeTxBody net (L.toStrict req.body) of + Left _ -> raise st $ UserError "Failed to parse request body" + Right tx -> return tx + +-- | Read a transaction from a request body. The body is the transaction in +-- hex or as raw bytes. White space in the hex is ignored. +-- +-- The body must hold one transaction and nothing else. Bytes after the +-- transaction are refused, as Bitcoin Core does for a raw transaction. +-- +-- The transaction must be in the format that peers of the network read. A +-- network without SegWit, such as Bitcoin Cash, has the format without +-- witness only. Its nodes would not read the SegWit format, so the store +-- does not take it either. +decodeTxBody :: Network -> C.ByteString -> Either String Tx +decodeTxBody net body = fromHex <> fromBytes body + where + fromBytes = runGetS $ do + tx <- getNetworkTx net + done <- isEmpty + unless done $ fail "Trailing bytes after transaction" + return tx + fromHex = + case parseBase16 (C.filter (not . isSpace) body) of + Right b16 -> fromBytes (decodeBase16 b16) + Left e -> Left (cs e) + +-- | Offset in the @offset@ parameter. Responds with an error if above the maximum. +parseOffset :: WebState -> Req -> IO OffsetParam +parseOffset st req = do + res@(OffsetParam o) <- paramDef st req + let limits = st.config.limits + when (limits.maxOffset > 0 && fromIntegral o > limits.maxOffset) $ + raise st . UserError $ + "offset exceeded: " <> show o <> " > " <> show limits.maxOffset + return res + +-- | The best block, if there is one. +bestBlock :: StoreRead -> IO (Maybe BlockData) +bestBlock q = q.getBestBlock >>= maybe (return Nothing) q.getBlock + +-- | Turn a start parameter into a position: a transaction, the block of a block +-- hash, a height, or the last block at or before a time. +parseStart :: + WebState -> + Maybe StartParam -> + IO (Maybe Start) +parseStart _ Nothing = return Nothing +parseStart st (Just s) = case s of + -- a transaction if there is one with that hash, else a block + StartParamHash {hash = h} -> + st.query.getTxData (TxHash h) >>= \case + Just _ -> return (Just (AtTx (TxHash h))) + Nothing -> fmap (AtBlock . (.height)) <$> st.query.getBlock (H.BlockHash h) + StartParamHeight {height = h} -> return (Just (AtBlock (fromIntegral h))) + StartParamTime {time = q} -> + fmap (AtBlock . (.height)) <$> C.blockAtOrBefore st.query st.config.store.chain q + +-- | Limit, offset and start in the parameters of a request. +parseLimits :: WebState -> Req -> IO LimitsParam +parseLimits st req = LimitsParam <$> paramOptional st req <*> parseOffset st req <*> paramOptional st req + +-- | Pagination of a query from request parameters, within the limits for full or short items. +paramToLimits :: + WebState -> + Bool -> + LimitsParam -> + IO Limits +paramToLimits st full (LimitsParam limitM o startM) = do + let wl = st.config.limits + Limits (validateLimit wl full limitM) (fromIntegral o) <$> parseStart st startM + +-- | Limit of a query: the requested one or the default, but no more than the maximum. +validateLimit :: WebLimits -> Bool -> Maybe LimitParam -> Word32 +validateLimit wl full limitM = + f m $ maybe d (fromIntegral . (.get)) limitM + where + m + | full && wl.maxFullItemCount > 0 = wl.maxFullItemCount + | otherwise = wl.maxItemCount + d = wl.defItemCount + f a 0 = a + f 0 b = b + f a b = min a b + +--------------- +-- Utilities -- +--------------- + +-- | The queries that the web server answers with: those of the database, +-- with the Redis cache, if there is one, in front of the queries about xpubs +-- and of the bodies of transactions. An xpub that the cache does not have is +-- read from the database, and cached for next time if it is large enough. +-- +-- When Redis does not answer, every query is answered from the database, as +-- if the store had no cache. The variable says whether Redis answered the +-- last time: a query that fails clears it, so that the next ones do not wait +-- for Redis in turn, and the health check sets it again when Redis is back. +webQuery :: Store -> TVar Bool -> StoreRead -> StoreRead +webQuery s up base = case s.cache of + Nothing -> base + Just c -> + (base :: StoreRead) + { getTxData = fmap listToMaybe' . txData c . pure, + getManyTxData = txData c, + xPubBals = \x -> + cached (cacheXPubBals c x) >>= \case + Just bals -> return bals + Nothing -> do + bals <- base.xPubBals x + _ <- cached (Just <$> cacheRequest c x bals) + return bals, + xPubUnspents = \x bals l -> + cached (cacheXPubUnspents c x bals l) >>= maybe (base.xPubUnspents x bals l) return, + xPubTxs = \x bals l -> + cached (cacheXPubTxs c x l) >>= maybe (base.xPubTxs x bals l) return, + xPubTxCount = \x bals -> + cached (cacheXPubTxCount c x) >>= maybe (base.xPubTxCount x bals) return + } + where + -- ask Redis, unless it is down, and take a failure, or no answer within + -- two seconds, for "not cached" + cached :: IO (Maybe a) -> IO (Maybe a) + cached ask = + readTVarIO up >>= \case + False -> return Nothing + True -> + (timeout 2000000 ask `catchAny` \_ -> return Nothing) >>= \case + Just answer -> return answer + Nothing -> atomically (writeTVar up False) >> return Nothing + -- bodies from Redis when the cache has them, so that the transactions + -- of a cached xpub are served in full even before this store has + -- imported them, and from the database otherwise + txData _ [] = return [] + txData c ths = do + found <- cached (Just <$> cacheTxData c ths) + let fromCache = fromMaybe (map (const Nothing) ths) found + missing = [h | (h, Nothing) <- zip ths fromCache] + fromDB <- HashMap.fromList . zip missing <$> base.getManyTxData missing + -- deleted ones are left out, wherever they come from + return $ + zipWith + (\h m -> notDeleted (maybe (fromMaybe Nothing (HashMap.lookup h fromDB)) Just m)) + ths + fromCache + +-- | The state of the web server, answering without the cache if the flag is +-- 'True', as @nocache=true@ asks. +cacheOr :: Bool -> WebState -> WebState +cacheOr False st = st +cacheOr True st = (st :: WebState) {query = st.direct} + +-- | The only element of a list of one optional value. +listToMaybe' :: [Maybe a] -> Maybe a +listToMaybe' [x] = x +listToMaybe' _ = Nothing + +-- | Middleware that logs every request with its response status: errors at error level, others at debug level. +logIt :: Logger -> Middleware +logIt logger app req respond = + app req $ \res -> do + let s = responseStatus res + msg = fmtReq req <> ": " <> fmtStatus s + if statusIsSuccessful s + then logDebug logger msg + else logError logger msg + respond res + +-- | Describe a request for logs. +fmtReq :: Request -> Text +fmtReq req = + let m = requestMethod req + v = httpVersion req + p = rawPathInfo req + q = rawQueryString req + in T.decodeUtf8 (m <> " " <> p <> q <> " " <> cs (show v)) + +-- | Describe a response status for logs. +fmtStatus :: Status -> Text +fmtStatus s = cs (show (statusCode s)) <> " " <> cs (statusMessage s) + +-- | A parameter read with a parser, or the default if there is none. Answers +-- with an error if it does not parse ('readParam'). +paramOr :: Req -> (Text -> Maybe a) -> Text -> a -> IO a +paramOr req f name d = param req name >>= maybe (return d) (readParam f name) + +-- | A parameter read with a parser. Answers with an error if there is none or +-- it does not parse ('readParam'). +requireParam :: WebState -> Req -> (Text -> Maybe a) -> Text -> IO a +requireParam st req f name = + param req name >>= maybe (raise st (UserError ("Missing parameter " <> T.unpack name))) (readParam f name) + +-- | The value of a parameter, read with a parser. Answers with an error that +-- names the parameter and the value if it does not parse: a value that the +-- server does not understand is a mistake of the client, and answering as if +-- it had not been given would hide the mistake. +readParam :: (Text -> Maybe a) -> Text -> Text -> IO a +readParam f name t = + maybe (throwIO (invalidParam name t)) return (f t) + +-- | The error for a value of a parameter that does not parse. +invalidParam :: Text -> Text -> Except +invalidParam name t = + UserError . T.unpack $ "Invalid value for parameter " <> name <> ": " <> t + +-- | A count, offset or number of confirmations: a whole number, not negative. +readNat :: Text -> Maybe Natural +readNat t = readMaybe (T.unpack t) >>= \(n :: Integer) -> if n < 0 then Nothing else Just (fromInteger n) + +-- | @true@ or @false@, in any case. +readBool :: Text -> Maybe Bool +readBool t = case T.toLower t of + "true" -> Just True + "false" -> Just False + _ -> Nothing + +-- | A number in decimal. +readNum :: (Read a) => Text -> Maybe a +readNum = readMaybe . T.unpack diff --git a/src/Haskoin/Store/Web/Docs.hs b/src/Haskoin/Store/Web/Docs.hs new file mode 100644 --- /dev/null +++ b/src/Haskoin/Store/Web/Docs.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- Module : Haskoin.Store.Web.Docs +-- Copyright : (c) Haskoin Developers +-- License : MIT +-- Maintainer : jprupp@protonmail.ch +-- Stability : experimental +-- Portability : POSIX +-- +-- The reference of the API, served by the server that it describes: the +-- page at the root of the server, and the description that the page reads. +-- +-- = Why the server carries its own reference +-- +-- @swagger.yaml@ is the reference of the API. A copy on a web site +-- describes whatever version that site was last given, and someone who +-- runs a server wants the reference of the server in front of them. So the +-- file is compiled into the program ('swaggerYaml'), and the root of the +-- server answers with a page that shows it ('swaggerPage'), with the +-- server itself first in its list of servers, so that requests tried from +-- the page go to it. +-- +-- = What the page needs +-- +-- The page is Swagger UI, loaded from a public CDN at a fixed version, as +-- the page of api.haskoin.com does. A browser without access to the +-- Internet shows an empty page; @\/swagger.yaml@ is served either way. The +-- program is not made a megabyte and a half larger to carry a copy of it. +module Haskoin.Store.Web.Docs + ( swaggerYaml, + swaggerPage, + ) +where + +import Data.ByteString (ByteString) +import Data.ByteString qualified as B +import Data.FileEmbed (embedFile, makeRelativeToProject) + +-- | @swagger.yaml@ as it was when the program was built, with this server +-- at the head of its list of servers: a relative address, which a reader of +-- the description resolves against where it found the description. +swaggerYaml :: ByteString +swaggerYaml = case B.breakSubstring marker file of + (before, rest) + | B.null rest -> file + | otherwise -> before <> marker <> " - url: './'\n description: This server\n" <> B.drop (B.length marker) rest + where + marker = "servers:\n" + file = $(makeRelativeToProject "swagger.yaml" >>= embedFile) + +-- | The page at the root of the server: Swagger UI, showing 'swaggerYaml', +-- which it asks this server for, next to wherever the page itself is. +swaggerPage :: ByteString +swaggerPage = + B.intercalate + "\n" + [ "", + "", + "", + " ", + " ", + " Haskoin Store API", + " cdn <> "/swagger-ui.css\">", + "", + "", + "
", + " ", + " ", + " ", + " ", + "", + "", + "" + ] + where + cdn = "https://unpkg.com/swagger-ui-dist@5.17.14" diff --git a/src/Haskoin/Store/Web/Events.hs b/src/Haskoin/Store/Web/Events.hs new file mode 100644 --- /dev/null +++ b/src/Haskoin/Store/Web/Events.hs @@ -0,0 +1,380 @@ +{-# LANGUAGE MultiWayIf #-} + +-- | +-- Module : Haskoin.Store.Web.Events +-- Copyright : (c) Haskoin Developers +-- License : MIT +-- Maintainer : jprupp@protonmail.ch +-- Stability : experimental +-- Portability : POSIX +-- +-- What the clients of @\/events@ are told: a log of the last events that +-- every client reads at its own pace, and the choice that a client makes of +-- the transactions it wants to hear about. +-- +-- = One log instead of a queue for each client +-- +-- Every client used to have a queue of its own, filled as events came. A +-- queue knows nothing of what came before it was made, so a client that +-- lost its connection for a second had no way to ask for what it missed, +-- and had to read everything again. +-- +-- Here the events are kept once, numbered, in an t'EventLog' of the last +-- 'logLength'. A client is a number, the next event that it has not read +-- ('readEvents'). A client that connects starts at the end +-- ('eventsEnd'), or after an event that it names by its hash +-- ('eventsAfter'), which is how it takes up where it left. A client that +-- is slower than the events come falls off the start of the log and is +-- told so, as it was when its queue filled. +-- +-- An event is named by its hash and not by its number, because the number +-- is that of one server since it started. In a fleet every server reads +-- the same stream of events from Redis, from the start of what Redis +-- keeps, so the logs of the servers hold the same events in the same +-- order, and a client may come back to another server than the one it +-- left. +-- +-- A transaction can be in the log twice, when it entered the mempool and +-- when it left. A client that names it is taken to have heard the first, +-- and hears everything after it again: an event told twice costs a +-- request, and an event not told is a payment that a wallet does not show. +-- +-- = Choosing transactions +-- +-- A client of the WebSocket can say which transactions it cares for, with +-- the commands of t'EventCommand': addresses, extended public keys, and a +-- Bloom filter as in BIP 37. What it chose is its t'Watch', and 'relevant' +-- decides for each transaction. So that it can, the log keeps the +-- transaction and its addresses with the event (see t'Seen'), read once when +-- the event comes, whatever the number of clients. +-- +-- When the server does not know the transaction of an event, every client +-- is told of it. That happens when a transaction leaves the mempool long +-- after the log forgot that it entered, and it errs on the side of telling +-- too much. +-- +-- An extended public key is watched as a wallet uses it: the addresses in +-- use and the gap after them on each of its two chains. When a transaction +-- touches one, the gap moves on ('relevant' returns the new t'Watch'), so +-- the client goes on hearing of payments to addresses it had not been +-- given yet when it subscribed. The same key may be watched under each +-- type of address, with a command for each. +-- +-- The Bloom filter is tested as a node tests it for an SPV client +-- ('bloomRelevantUpdate'), except that the server does not add the +-- outputs of a matching transaction to the filter: the filter stays as the +-- client made it, and the client adds what it wants to follow +-- ('EventFilterAdd'). A filter that changed behind the back of the client +-- could not be told apart from its own after a few matches. +module Haskoin.Store.Web.Events + ( -- * Log + EventLog, + Happened (..), + Entry (..), + Seen (..), + seenOf, + newEventLog, + appendEvent, + eventsEnd, + eventsAfter, + readEvents, + logLength, + logWeight, + + -- * Choice of a client + Watch (..), + everything, + nothing, + relevant, + command, + maxWatchAddresses, + maxWatchXPubs, + ) +where + +import Control.Concurrent.STM + ( STM, + TVar, + atomically, + modifyTVar', + newTVarIO, + readTVar, + retry, + stateTVar, + ) +import Data.ByteString qualified as B +import Data.Either (rights) +import Data.HashMap.Strict (HashMap) +import Data.HashMap.Strict qualified as HashMap +import Data.HashSet (HashSet) +import Data.HashSet qualified as HashSet +import Data.IntMap.Strict qualified as IntMap +import Data.Maybe (isJust, mapMaybe) +import Data.Sequence (Seq, ViewL (..), (|>)) +import Data.Sequence qualified as Seq +import Data.Word (Word32, Word64) +import Haskoin + ( Address, + BlockHash, + BloomFilter, + Ctx, + Network, + Tx (..), + TxHash, + TxOut (..), + bloomInsert, + bloomRelevantUpdate, + pubSubKey, + scriptToAddressBS, + ) +import Haskoin.Store.Common (deriveFunction) +import Haskoin.Store.Data + ( Event (..), + EventCommand (..), + Prev (..), + TxData (..), + XPubBal (..), + XPubSpec (..), + nullBalance, + ) + +-- | What the server knows of a transaction that an event is about: enough +-- to say whether a client wants to hear of it. +data Seen = Seen + { -- | the transaction, for the Bloom filter + tx :: !Tx, + -- | the addresses that it pays to and spends from + addresses :: !(HashSet Address), + -- | roughly the bytes that this takes in memory + size :: !Int + } + deriving (Eq, Show) + +-- | A transaction as the log keeps it. +seenOf :: Network -> Ctx -> TxData -> Seen +seenOf net ctx td = + Seen + { tx = td.tx, + addresses = HashSet.fromList (rights (map (scriptToAddressBS net ctx) scripts)), + size = 256 + sum (map B.length scripts) + sum (map (sum . map B.length) td.tx.witness) + } + where + scripts = map (.script) (IntMap.elems td.prevs) <> map (.script) td.tx.outputs + +-- | Something that the clients are told. +data Happened + = -- | the best block changed to this one + BlockArrived !BlockHash + | -- | a transaction entered the mempool, with what is known of it + TxEntered !TxHash !(Maybe Seen) + | -- | a transaction left the mempool unconfirmed + TxLeft !TxHash + deriving (Eq, Show) + +-- | An event in the log. +data Entry = Entry + { -- | its place: one more than that of the event before + number :: !Word64, + -- | what the client is sent + event :: !Event, + -- | the transaction, when the event is about one that the server knows + seen :: !(Maybe Seen), + -- | the bytes that this entry is counted for in the log + weight :: !Int + } + deriving (Eq, Show) + +-- | The last events, oldest first. +data Log = Log + { entries :: !(Seq Entry), + -- | the number of the next event + next :: !Word64, + -- | the sum of the weights of the entries + held :: !Int, + -- | the transactions of the entries that say that one entered, to + -- know them again when they leave + bodies :: !(HashMap TxHash Seen) + } + +-- | The log of events that the clients of a server read. +newtype EventLog = EventLog (TVar Log) + +-- | The most events that the log keeps: how far back a client can take up +-- from, and how far behind it may fall. +logLength :: Int +logLength = 10000 + +-- | The most bytes of transactions that the log keeps. Events of large +-- transactions make the log shorter instead of making the server larger. +logWeight :: Int +logWeight = 64 * 1024 * 1024 + +-- | An empty log. +newEventLog :: IO EventLog +newEventLog = EventLog <$> newTVarIO Log {entries = Seq.empty, next = 0, held = 0, bodies = HashMap.empty} + +-- | Add an event at the end of the log, and drop from the start what the +-- log has no room for. +appendEvent :: EventLog -> Happened -> STM () +appendEvent (EventLog var) what = modifyTVar' var $ \l -> + let entry = case what of + BlockArrived h -> Entry {number = l.next, event = EventBlock h, seen = Nothing, weight = 0} + TxEntered h s -> Entry {number = l.next, event = EventTx h, seen = s, weight = maybe 0 (.size) s} + TxLeft h -> Entry {number = l.next, event = EventTx h, seen = HashMap.lookup h l.bodies, weight = 0} + bodies = case what of + TxEntered h (Just s) -> HashMap.insert h s l.bodies + _ -> l.bodies + in trim Log {entries = l.entries |> entry, next = l.next + 1, held = l.held + entry.weight, bodies} + where + trim l = case Seq.viewl l.entries of + e :< rest + | Seq.length l.entries > logLength || l.held > logWeight -> + trim Log {entries = rest, next = l.next, held = l.held - e.weight, bodies = forget e l.bodies} + _ -> l + forget e = case e.event of + EventTx h | e.weight > 0 -> HashMap.delete h + _ -> id + +-- | Where a client that wants only what comes from now on starts reading. +eventsEnd :: EventLog -> STM Word64 +eventsEnd (EventLog var) = (.next) <$> readTVar var + +-- | Where a client that has heard of an event starts reading, given the +-- hash of the block or of the transaction: after the first event about +-- it. 'Nothing' when the log has no such event, because it never had or +-- because it is too long ago; the client then has to read what it follows +-- again and start from the end. +eventsAfter :: EventLog -> Maybe BlockHash -> Maybe TxHash -> STM (Maybe Word64) +eventsAfter (EventLog var) block tx = do + l <- readTVar var + let is e = case e.event of + EventBlock h -> Just h == block + EventTx h -> Just h == tx + return $ (\i -> (Seq.index l.entries i).number + 1) <$> Seq.findIndexL is l.entries + +-- | The events from a number on, waiting for one when there is none yet. +-- 'Nothing' when the log no longer has that number: the client fell too +-- far behind. +readEvents :: EventLog -> Word64 -> STM (Maybe (Seq Entry)) +readEvents (EventLog var) from = do + l <- readTVar var + let first = l.next - fromIntegral (Seq.length l.entries) + if + | from < first -> return Nothing + | from >= l.next -> retry + | otherwise -> return (Just (Seq.drop (fromIntegral (from - first)) l.entries)) + +-- | What a client of the WebSocket chose to hear about. +data Watch = Watch + { -- | whether it chose at all; a client that did not hears everything + filtered :: !Bool, + -- | the addresses that it named + plain :: !(HashSet Address), + -- | the keys that it named, with the number of addresses derived on + -- the external and on the change chain + keys :: !(HashMap XPubSpec (Word32, Word32)), + -- | the addresses derived from the keys: the key, the chain and the + -- index of each + derived :: !(HashMap Address (XPubSpec, Word32, Word32)), + -- | its Bloom filter + bloom :: !(Maybe BloomFilter) + } + deriving (Eq, Show) + +-- | The choice of a client that has not chosen: every transaction. +everything :: Watch +everything = + Watch {filtered = False, plain = HashSet.empty, keys = HashMap.empty, derived = HashMap.empty, bloom = Nothing} + +-- | The choice of a client that wants blocks alone, until it names +-- something to watch. +nothing :: Watch +nothing = everything {filtered = True} + +-- | The most addresses that a client may name. Those derived from keys do +-- not count. +maxWatchAddresses :: Int +maxWatchAddresses = 100000 + +-- | The most extended public keys that a client may name. Each is read +-- from the database when it is named, as a request about it is. +maxWatchXPubs :: Int +maxWatchXPubs = 100 + +-- | Whether a client is told of an event, given what the log knows of its +-- transaction, and its choice afterwards: the gap of a key moves on when +-- the transaction touches one of its addresses. The gap is the number of +-- unused addresses to watch after the last one used. +-- +-- A client that has not chosen is told of everything, and every client is +-- told of a block and of a transaction that the server does not know. +relevant :: Ctx -> Word32 -> Maybe Seen -> Watch -> (Bool, Watch) +relevant _ _ Nothing w = (True, w) +relevant ctx gap (Just s) w + | not w.filtered = (True, w) + | otherwise = (named || not (null hits) || matched, foldl' moved w hits) + where + touched = HashSet.toList s.addresses + named = any (`HashSet.member` w.plain) touched + hits = mapMaybe (`HashMap.lookup` w.derived) touched + matched = maybe False (\f -> isJust (bloomRelevantUpdate ctx f s.tx)) w.bloom + moved now (spec, chain, index) = extend ctx spec chain (index + 1 + gap) now + +-- | Derive the addresses of a watched key on one chain up to a number of +-- them, if there are fewer. +extend :: Ctx -> XPubSpec -> Word32 -> Word32 -> Watch -> Watch +extend ctx spec chain upto w = case HashMap.lookup spec w.keys of + Just (external, change) + | upto > have -> + w + { keys = HashMap.insert spec (if chain == 0 then (upto, change) else (external, upto)) w.keys, + derived = foldl' (\m i -> HashMap.insert (derive i) (spec, chain, i) m) w.derived [have .. upto - 1] + } + where + have = if chain == 0 then external else change + derive = deriveFunction ctx spec.deriv (pubSubKey ctx spec.key chain) + _ -> w + +-- | Do what a client asked with a command, and say why not when it cannot +-- be done, in which case the connection is to be closed. The function +-- reads the balances of an extended public key from the database. +command :: Ctx -> Word32 -> (XPubSpec -> IO [XPubBal]) -> TVar Watch -> EventCommand -> IO (Either String ()) +command ctx gap balances var = \case + EventWatch as -> change $ \w -> + let plain = foldl' (flip HashSet.insert) w.plain as + in if HashSet.size plain > maxWatchAddresses + then Left "Too many addresses" + else Right (chosen w) {plain} + EventUnwatch as -> change $ \w -> Right (chosen w) {plain = foldl' (flip HashSet.delete) w.plain as} + EventWatchXPub spec -> do + -- read before the choice changes: nothing is held while the database + -- is read + used <- balances spec + let upto chain = gap + maximum (0 : [i + 1 | XPubBal {path = [c, i], balance = b} <- used, c == chain, inUse b]) + change $ \w -> + if + | HashMap.member spec w.keys -> Right (chosen w) + | HashMap.size w.keys >= maxWatchXPubs -> Left "Too many extended public keys" + | otherwise -> + let named = (chosen w) {keys = HashMap.insert spec (0, 0) w.keys} + in Right (extend ctx spec 1 (upto 1) (extend ctx spec 0 (upto 0) named)) + EventUnwatchXPub spec -> change $ \w -> + Right + (chosen w) + { keys = HashMap.delete spec w.keys, + derived = HashMap.filter (\(s, _, _) -> s /= spec) w.derived + } + EventFilterLoad f -> change $ \w -> Right (chosen w) {bloom = Just f} + EventFilterAdd d -> change $ \w -> case w.bloom of + Nothing -> Left "No filter to add to" + Just f -> Right w {bloom = Just (bloomInsert f d)} + EventFilterClear -> change $ \w -> Right (chosen w) {bloom = Nothing} + EventAll -> change (const (Right everything)) + EventNone -> change (const (Right nothing)) + where + chosen w = w {filtered = True} + inUse b = not (nullBalance b) + change :: (Watch -> Either String Watch) -> IO (Either String ()) + change f = atomically . stateTVar var $ \w -> case f w of + Left why -> (Left why, w) + Right new -> (Right (), new) diff --git a/src/Haskoin/Store/Web/Router.hs b/src/Haskoin/Store/Web/Router.hs new file mode 100644 --- /dev/null +++ b/src/Haskoin/Store/Web/Router.hs @@ -0,0 +1,231 @@ +-- | +-- Module : Haskoin.Store.Web.Router +-- Copyright : (c) Haskoin Developers +-- License : MIT +-- Maintainer : jprupp@protonmail.ch +-- Stability : experimental +-- Portability : POSIX +-- +-- Routing of requests to handlers, directly over WAI. +-- +-- A 'Route' is a method, a path pattern such as @\/block\/:block@, the names +-- of the parameters it accepts in the query string or a form, and a handler: +-- a function from the request to a response in 'IO'. 'router' turns a list of +-- them into a WAI 'Application' that answers with the first route whose +-- method and path match. A handler that finds the request is not for it after +-- all, such as one whose path parameter does not parse as the kind of value +-- it serves, calls 'next', and the request goes to the next route that +-- matches. +-- +-- = Parameters are declared +-- +-- A request with a parameter that its route does not accept is refused +-- ('Unknown'), rather than answered as if the parameter were not there. A +-- misspelt parameter, such as @limt=10@, or one that an endpoint does not +-- support, would otherwise be ignored, and the client would get an answer to +-- a question it did not ask, with nothing to tell it so. The check runs +-- before the handler, so a refused request has no effect, which matters for +-- a handler that does something, such as broadcasting a transaction. +-- +-- The declaration and the handler cannot drift apart: reading a parameter +-- that the route does not declare ('param') throws 'Undeclared', an error of +-- the program that the tests of each endpoint find, rather than a parameter +-- that is accepted and never read, or read and never accepted. +-- +-- = Why not a web framework +-- +-- The server needs routing, parameters and responses; a framework like +-- Scotty adds them in a monad transformer over 'IO' that every handler has to +-- run in, with its own exceptions for control flow and its own way to return +-- a response. Here a handler is a plain function: it gets everything about +-- the request in a 'Req', returns a WAI 'Response', and stops early by +-- throwing, which 'router' and the server catch. The whole router is this +-- module. +module Haskoin.Store.Web.Router + ( -- * Routes + Route (..), + Miss (..), + Undeclared (..), + route, + get, + post, + router, + routerScoped, + + -- * Requests + Req (..), + Next (..), + next, + capture, + captureWith, + param, + header, + ) +where + +import Control.Applicative ((<|>)) +import Control.Exception (Exception, catch, throwIO) +import Data.ByteString.Lazy qualified as L +import Data.CaseInsensitive qualified as CI +import Data.List (nub) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Encoding (decodeUtf8Lenient, encodeUtf8) +import Network.HTTP.Types (Method, methodGet, methodPost, parseQueryText) +import Network.Wai + +-- | A request being answered. +data Req = Req + { -- | the request of WAI + wai :: !Request, + -- | the parameters captured from the path, by name + captures :: ![(Text, Text)], + -- | the parameters of the query string, then those of a form in the + -- body; the first one of a name is the one that counts + params :: ![(Text, Text)], + -- | the body, read whole before the handler runs + body :: !L.ByteString, + -- | the names of the parameters that the route accepts + accepted :: ![Text] + } + +-- | Where a request should go. +data Route = Route + { method :: !Method, + -- | the segments of the path: literals, and captures by name + pattern :: ![Either Text Text], + -- | the names of the parameters it accepts in the query string or a form + accepts :: ![Text], + handler :: Req -> IO Response + } + +-- | A route for a method, a path such as @\/block\/:block@, where a segment +-- that starts with a colon captures what is there under its name, and the +-- names of the parameters it accepts. +route :: Method -> Text -> [Text] -> (Req -> IO Response) -> Route +route m path = Route m [segment t | t <- T.splitOn "/" path, not (T.null t)] + where + segment t = maybe (Left t) Right (T.stripPrefix ":" t) + +-- | A route for @GET@. +get :: Text -> [Text] -> (Req -> IO Response) -> Route +get = route methodGet + +-- | A route for @POST@. +post :: Text -> [Text] -> (Req -> IO Response) -> Route +post = route methodPost + +-- | Why no route answered a request. +data Miss + = -- | no route has its method and path + NoRoute + | -- | the routes with its method and path do not accept these parameters + Unknown ![Text] + deriving stock (Show) + +-- | What 'param' throws for a parameter that the route does not declare: a +-- mistake in the program, not in the request. +newtype Undeclared = Undeclared Text + deriving stock (Show) + +instance Exception Undeclared + +-- | What a handler throws to pass the request to the next route that +-- matches. +data Next = Next + deriving stock (Show) + +instance Exception Next + +-- | Pass the request to the next route that matches. +next :: IO a +next = throwIO Next + +-- | An application that answers with the first route whose method and path +-- match the request, that accepts all its parameters, and whose handler does +-- not pass it on; or with the fallback, told why none did. The body of the +-- request is read whole first, and parsed as a form if it is one; handlers +-- that stream a response still stream it. +router :: [Route] -> (Req -> Miss -> IO Response) -> Application +router routes = routerScoped routes ($ routes) + +-- | 'router' for handlers that need something that lasts as long as one +-- request does, such as a view of a database that must be the same for +-- everything the request reads and must be let go when it is answered. +-- +-- The routes are given twice. The first list is used for its methods, paths +-- and parameters only, to find the route of a request. The second argument +-- runs an action with the same routes, in the same order, made for the one +-- request: the handler that answers is taken from those. The response is +-- sent inside that action, so that a handler that streams its response can +-- go on reading while it is sent. +-- +-- The alternative, to make the routes once and have each handler take what +-- it needs for itself, would put that in every handler; and making all the +-- routes again for each request, to match against, would cost more than +-- many requests do. +routerScoped :: + [Route] -> + (([Route] -> IO (Maybe ResponseReceived)) -> IO (Maybe ResponseReceived)) -> + (Req -> Miss -> IO Response) -> + Application +routerScoped routes scoped fallback request respond = do + body <- strictRequestBody request + let form + | lookup "Content-Type" (requestHeaders request) + == Just "application/x-www-form-urlencoded" = + parseQueryText (L.toStrict body) + | otherwise = [] + params = [(k, maybe "" id v) | (k, v) <- queryToText (queryString request) <> form] + req cs as = Req {wai = request, captures = cs, params = params, body = body, accepted = as} + path = filter (not . T.null) (pathInfo request) + -- the parameters that the first route matching the path refused, if any + go unknown [] = fallback (req [] []) (maybe NoRoute Unknown unknown) >>= respond + go unknown ((i, r) : rs) + | r.method == requestMethod request, + Just cs <- match r.pattern path = + case nub [k | (k, _) <- params, k `notElem` r.accepts] of + [] -> scoped (answer i (req cs r.accepts)) >>= maybe (go unknown rs) return + ks -> go (unknown <|> Just ks) rs + | otherwise = go unknown rs + go Nothing (zip [0 :: Int ..] routes) + where + -- the response of the handler of a route, sent, or nothing if the + -- handler passed the request on + answer i r scopedRoutes = + ((Just <$> (scopedRoutes !! i).handler r) `catch` \Next -> return Nothing) >>= mapM respond + queryToText q = [(decodeUtf8Lenient k, decodeUtf8Lenient <$> v) | (k, v) <- q] + +-- | The captures of a path, if it matches a pattern. +match :: [Either Text Text] -> [Text] -> Maybe [(Text, Text)] +match [] [] = Just [] +match (Left l : ps) (t : ts) | l == t = match ps ts +match (Right n : ps) (t : ts) = ((n, t) :) <$> match ps ts +match _ _ = Nothing + +-- | A parameter captured from the path. Passes the request on if there is +-- none of that name, which only a wrong pattern would cause. +capture :: Req -> Text -> IO Text +capture r n = maybe next return (lookup n r.captures) + +-- | A parameter captured from the path, read with a parser. Passes the +-- request on if it does not parse: the path may be meant for another route, +-- such as an xpub where an address is expected. +captureWith :: Req -> (Text -> Maybe a) -> Text -> IO a +captureWith r f n = capture r n >>= maybe next return . f + +-- | A parameter of the query string or of a form, if there is one. Throws +-- 'Undeclared' if the route does not accept a parameter of that name. +-- +-- It is an action rather than a pure function so that the error is thrown +-- when the parameter is read, inside the handler, where the server answers +-- it, and not whenever the value happens to be evaluated, which may be while +-- the response is being sent. +param :: Req -> Text -> IO (Maybe Text) +param r n + | n `elem` r.accepted = return (lookup n r.params) + | otherwise = throwIO (Undeclared n) + +-- | A header of the request, if there is one. +header :: Req -> Text -> Maybe Text +header r n = decodeUtf8Lenient <$> lookup (CI.mk (encodeUtf8 n)) (requestHeaders r.wai) diff --git a/stress/Main.hs b/stress/Main.hs new file mode 100644 --- /dev/null +++ b/stress/Main.hs @@ -0,0 +1,913 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- Module : Main +-- Copyright : (c) Haskoin Developers +-- License : MIT +-- Maintainer : jprupp@protonmail.ch +-- Stability : experimental +-- Portability : POSIX +-- +-- Stress test of the Redis cache of xpubs. Run it with +-- @scripts/stress-cache.sh@, which builds it, runs it and writes a report. +-- +-- It starts a regtest chain of Bitcoin Core, Valkey and wrk in Podman +-- containers from the test image ("Haskoin.Store.Integration.Image"), and a +-- haskoin-store server with the cache on. A few wallets, whose keys this +-- program holds, get many coins; then the program makes transactions between +-- them, signed here and sent to the node in batches, and mines a block after +-- each batch. Every transaction changes two cached xpubs, so the cache +-- reloads them again and again while wrk asks the server about them on five +-- endpoints at once. At the end, the cached answers are compared with those +-- of the database. +-- +-- Everything it measures goes to files in the output directory, as JSON +-- lines: @rounds.jsonl@ (one line per block), @samples.jsonl@ (one line per +-- second: heights, CPU, memory and the StatsD metrics of the server), +-- @wrk.jsonl@ (one line per run of wrk) and @summary.json@. +-- @scripts/stress-report.py@ turns them into a report. +-- +-- = Why it works this way +-- +-- * __Transactions are signed here.__ A node wallet makes a few hundred +-- transactions per second at best, and slower as it grows; signing with +-- the keys in memory and sending raw transactions in batches keeps the node +-- busy only with validating them. +-- * __Only confirmed coins are spent.__ A block is mined after each batch, so +-- chains of unconfirmed transactions, which the node limits, never form. +-- * __The server is a separate process__, the release binary, so that its +-- CPU and memory are its own, and it is configured from the command line +-- as in production. +-- * __Containers are removed__ when the program ends, even when it fails: +-- they run with @--rm@ inside brackets, and carry a label with the process +-- ID, so that @scripts/stress-cache.sh@ and the next run remove any that a +-- killed run left. +module Main (main) where + +import Control.Concurrent.STM (TVar, atomically, newTVarIO, readTVarIO, writeTVar) +import Control.DeepSeq (force) +import Control.Exception (evaluate) +import Control.Lens ((&), (.~), (?~), (^.)) +import Control.Monad (forM, forM_, unless, void, when) +import Data.Aeson (Value (..), eitherDecode, encode, object, (.=)) +import Data.Aeson qualified as A +import Data.ByteString qualified as BS +import Data.ByteString.Char8 qualified as C8 +import Data.ByteString.Lazy qualified as BL +import Data.Bytes.Put (runPutS) +import Data.Bytes.Serial (serialize) +import Data.FileEmbed (embedFile, makeRelativeToProject) +import Data.Foldable (toList) +import Data.HashMap.Strict (HashMap) +import Data.HashMap.Strict qualified as HashMap +import Data.IORef (IORef, atomicModifyIORef', newIORef) +import Data.List (sort) +import Data.Maybe (fromMaybe, mapMaybe) +import Data.Sequence (Seq) +import Data.Sequence qualified as Seq +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Encoding (decodeUtf8) +import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime) +import Data.Word (Word64) +import Database.Redis qualified as Redis +import Haskoin hiding (Coin, Key) +import Haskoin.Store.Integration.Image (testImage, valkeyBin, wrkBin) +import Haskoin.Store.Integration.Node +import Haskoin.Store.Integration.Podman +import Haskoin.Store.Integration.Valkey (redisContainer, waitRedis) +import Network.Socket qualified as Socket +import Network.Socket.ByteString qualified as SocketB +import Network.Wreq qualified as Wreq +import Numeric (readHex) +import Options.Applicative +import System.Exit (ExitCode (..)) +import System.IO (Handle, IOMode (..), hFlush, hPutStrLn, stderr, withFile) +import System.Process +import System.Random.Stateful (IOGenM, StdGen, mkStdGen, newIOGenM, uniformRM) +import Text.Read (readMaybe) +import UnliftIO (MVar, bracket, newMVar, tryAny, withAsync, withMVar) +import UnliftIO.Concurrent (threadDelay) +import UnliftIO.Directory (createDirectoryIfMissing, makeAbsolute) + +------------------------------------------------------------------------------- +-- Options +------------------------------------------------------------------------------- + +data Opts = Opts + { txs :: !Int, + wallets :: !Int, + addresses :: !Int, + blockTxs :: !Int, + batch :: !Int, + connections :: !Int, + wrkSeconds :: !Int, + server :: !FilePath, + serverRts :: !String, + out :: !FilePath, + chainMb :: !Int, + seed :: !Int + } + +opts :: Parser Opts +opts = do + txs <- num "txs" 200000 "Transactions to make between the wallets" + wallets <- num "wallets" 4 "Wallets, each an xpub" + addresses <- num "addresses" 200 "Receiving and change addresses of each wallet" + blockTxs <- num "block-txs" 2000 "Transactions per block" + batch <- num "batch" 250 "Transactions per call to the node" + connections <- num "connections" 2 "Connections of wrk to each endpoint" + wrkSeconds <- num "wrk-seconds" 10 "Seconds of each run of wrk" + server <- strOption (long "server" <> metavar "PATH" <> help "haskoin-store binary") + serverRts <- + strOption $ + long "server-rts" + <> metavar "FLAGS" + <> value "-N4 -M2g" + <> showDefault + <> help "RTS flags of the server" + out <- strOption (long "out" <> metavar "DIR" <> help "Directory for the results") + chainMb <- num "chain-mb" 1024 "Size of the tmpfs of the chain of the node, in MiB" + seed <- num "seed" 1 "Seed of the random choices" + return Opts {..} + where + num name def h = option auto (long name <> metavar "N" <> value def <> showDefault <> help h) + +------------------------------------------------------------------------------- +-- Main +------------------------------------------------------------------------------- + +main :: IO () +main = do + o <- execParser (info (opts <**> helper) (fullDesc <> progDesc "Stress test of the Redis cache of haskoin-store")) + outDir <- makeAbsolute o.out + createDirectoryIfMissing True outDir + podmanUsable >>= either fail return + say "Building or finding the test image" + image <- testImage + withContext $ \ctx -> + withContainer (valkey image) $ \rc -> do + redisURL <- ("redis://127.0.0.1:" <>) . show <$> hostPort rc 6379 + waitRedis redisURL + withContainer (nodeSpec o image) $ \nc -> do + rpcPort <- hostPort nc 18443 + p2p <- hostPort nc 18444 + let node = Node {kind = BitcoinCore, url = "http://127.0.0.1:" <> show rpcPort <> "/", p2p = p2p} + waitRpc node + withContainer (wrkSpec image outDir) $ \wc -> + withStatsd $ \statsPort stats -> + withRamDir $ \dir -> + withServer o outDir dir redisURL p2p statsPort $ \srv -> + stress o {out = outDir} ctx node redisURL srv stats wc + +-- | Valkey with room for the bodies of every transaction. +valkey :: String -> ContainerSpec +valkey image = + let spec = redisContainer image + in spec + { options = ["--memory", "1g", "--entrypoint", valkeyBin], + command = map (\a -> if a == "128mb" then "768mb" else a) spec.command + } + +-- | The regtest node, with a larger chain and mempool than in the tests. +nodeSpec :: Opts -> String -> ContainerSpec +nodeSpec o image = + let spec = nodeContainer BitcoinCore image + in spec + { options = map grow spec.options, + command = map bigger spec.command <> ["-rpcworkqueue=64", "-rpcthreads=8"] + } + where + grow "1g" = "3g" + grow a + | "/chain:" `T.isPrefixOf` T.pack a = "/chain:rw,size=" <> show o.chainMb <> "m,mode=1777" + | otherwise = a + bigger "-dbcache=16" = "-dbcache=128" + bigger "-maxmempool=16" = "-maxmempool=128" + bigger a = a + +-- | A container that runs wrk against the server, on the network of the +-- host, with the output directory, where the scripts of wrk are, mounted. +wrkSpec :: String -> FilePath -> ContainerSpec +wrkSpec image dir = + ContainerSpec + { name = "wrk", + image = image, + options = + [ "--network", + "host", + "--memory", + "512m", + "--security-opt", + "label=disable", + "--volume", + dir <> ":/stress:ro", + "--entrypoint", + "sleep" + ], + command = ["infinity"], + ports = [] + } + +------------------------------------------------------------------------------- +-- The server +------------------------------------------------------------------------------- + +data Server = Server + { url :: !String, + pid :: !Int + } + +-- | Run the haskoin-store server while an action runs. +withServer :: Opts -> FilePath -> FilePath -> String -> Int -> Int -> (Server -> IO a) -> IO a +withServer o outDir dir redisURL p2p statsPort act = + withFile (outDir <> "/server.log") WriteMode $ \logH -> do + -- another program could take the port before the server binds it, but + -- the server then fails to start, which is reported + port <- freePort + let gap = o.addresses + 20 + args = + [ "--dir", + dir, + "--host", + "127.0.0.1", + "--port", + show port, + "--net", + "btcreg", + "--peer", + "127.0.0.1:" <> show p2p, + "--max-peers", + "1", + "--redis", + "--redis-url", + redisURL, + "--redis-min-addrs", + "10", + "--xpub-gap", + show gap, + "--xpub-gap-init", + show gap, + "--statsd", + "--statsd-host", + "127.0.0.1", + "--statsd-port", + show statsPort, + "--statsd-prefix", + "stress", + "--statsd-aggregates", + "--ticker-url", + "http://127.0.0.1:9/", + "--price-history-url", + "http://127.0.0.1:9/", + "+RTS" + ] + <> words o.serverRts + <> ["-RTS"] + cp = (proc o.server args) {std_out = UseHandle logH, std_err = UseHandle logH} + bracket (createProcess cp) stop $ \(_, _, _, ph) -> do + pid <- maybe (fail "The server did not start") (return . fromIntegral) =<< getPid ph + writeFile (outDir <> "/server.pid") (show pid) + let srv = Server {url = "http://127.0.0.1:" <> show port, pid = pid} + waitFor 60 "the server to answer" $ do + getProcessExitCode ph >>= \case + Just c -> fail ("The server exited with " <> show c <> "; see server.log") + Nothing -> either (const False) (const True) <$> tryAny (getJSON srv "/health") + act srv + where + stop (_, _, _, ph) = terminateProcess ph >> void (waitForProcess ph) + +-- | A free TCP port of the loopback interface. +freePort :: IO Int +freePort = + bracket (Socket.socket Socket.AF_INET Socket.Stream Socket.defaultProtocol) Socket.close $ \s -> do + Socket.bind s (Socket.SockAddrInet 0 (Socket.tupleToHostAddress (127, 0, 0, 1))) + fromIntegral <$> Socket.socketPort s + +-- | JSON answer of the server. +getJSON :: Server -> String -> IO Value +getJSON srv path = do + let o = Wreq.defaults & Wreq.checkResponse ?~ (\_ _ -> return ()) + r <- Wreq.getWith o (srv.url <> path) + either fail return (eitherDecode (r ^. Wreq.responseBody)) + +------------------------------------------------------------------------------- +-- Wallets +------------------------------------------------------------------------------- + +-- | An address and its key. +data Key = Key + { script :: !ScriptOutput, + secret :: !SecKey + } + +-- | A wallet: its xpub, and its receiving and change addresses. +data Wallet = Wallet + { xpub :: !Text, + receive :: !(Seq Key), + change :: !(Seq Key) + } + +-- | A coin that a wallet can spend. +data Coin = Coin + { outpoint :: !OutPoint, + value :: !Word64, + wallet :: !Int, + key :: !Key + } + +-- | The wallets, derived from a fixed seed, and the key of the miner. +makeWallets :: Ctx -> Opts -> ([Wallet], Key) +makeWallets ctx o = ([wallet (fromIntegral i) | i <- [0 .. o.wallets - 1]], keyOf (hardSubKey ctx root 9999) 0 0) + where + root = makeXPrvKey (C8.pack ("haskoin-store-stress-" <> show o.seed)) + wallet i = + let w = hardSubKey ctx root i + in Wallet + { xpub = xPubExport btcRegTest ctx (deriveXPubKey ctx w), + receive = Seq.fromList [keyOf w 0 j | j <- [0 .. fromIntegral o.addresses - 1]], + change = Seq.fromList [keyOf w 1 j | j <- [0 .. fromIntegral o.addresses - 1]] + } + keyOf w c j = + let k = prvSubKey ctx (prvSubKey ctx w c) j + a = xPubAddr ctx (deriveXPubKey ctx k) + in Key {script = fromMaybe (error "no script") (addressToOutput a), secret = k.key} + +-- | Address of a key, as text. +keyAddress :: Key -> Text +keyAddress k = case k.script of + PayPKHash h -> fromMaybe (error "no address") (addrToText btcRegTest (PubKeyAddress h)) + _ -> error "not a key hash" + +-- | Sign a transaction that spends coins. +sign :: Ctx -> Tx -> [Coin] -> Tx +sign ctx tx coins = + either error id $ + signTx + btcRegTest + ctx + tx + [SigInput c.key.script c.value c.outpoint sigHashAll Nothing | c <- coins] + [c.key.secret | c <- coins] + +-- | A payment from a coin to another wallet, with change back to the wallet +-- of the coin. Gives the transaction and its new coins. +pay :: Ctx -> IOGenM StdGen -> [Wallet] -> Coin -> IO (Tx, [Coin]) +pay ctx g ws c = do + w' <- (\i -> (c.wallet + i) `mod` length ws) <$> uniformRM (1, max 1 (length ws - 1)) g + let to = ws !! w' + from = ws !! c.wallet + r <- (`Seq.index` 0) . flip Seq.drop to.receive <$> uniformRM (0, Seq.length to.receive - 1) g + ch <- (`Seq.index` 0) . flip Seq.drop from.change <$> uniformRM (0, Seq.length from.change - 1) g + amount <- uniformRM (10000, max 10000 (c.value `div` 2)) g + -- every output is worth at least 10000, so a coin always pays the fee + let fee = 1000 + outs + | c.value >= amount + fee + 10000 = [(r.script, amount), (ch.script, c.value - amount - fee)] + | otherwise = [(r.script, c.value - fee)] + tx = sign ctx (buildTx ctx [c.outpoint] outs) [c] + h = txHash tx + owners = [(w', r), (c.wallet, ch)] + coins = [Coin (OutPoint h i) v w k | (i, (_, v), (w, k)) <- zip3 [0 ..] outs owners] + return (tx, coins) + +------------------------------------------------------------------------------- +-- The node +------------------------------------------------------------------------------- + +-- | Send transactions to the node in one call. Gives the error of each +-- transaction that the node refused. +sendRaw :: Node -> [Tx] -> IO [Maybe Value] +sendRaw node txs = do + let o = + Wreq.defaults + & Wreq.auth ?~ Wreq.basicAuth "test" "test" + & Wreq.checkResponse ?~ (\_ _ -> return ()) + & Wreq.header "Content-Type" .~ ["application/json"] + body = + A.toJSON + [ object + [ "jsonrpc" .= ("1.0" :: Text), + "id" .= i, + "method" .= ("sendrawtransaction" :: Text), + "params" .= [encodeHex (runPutS (serialize tx))] + ] + | (i, tx) <- zip [0 :: Int ..] txs + ] + r <- Wreq.postWith o node.url body + case eitherDecode (r ^. Wreq.responseBody) of + Right (Array xs) -> + return + [ case field "error" x of + Just Null -> Nothing + Nothing -> Nothing + e -> e + | x <- toList xs + ] + Right v -> fail ("Unexpected answer to a batch: " <> take 400 (show v)) + Left e -> fail ("Bad answer to a batch: " <> e) + +-- | The coinbase output of a block. +coinbaseOf :: Node -> Text -> IO (OutPoint, Word64) +coinbaseOf node h = do + b <- rpc node "getblock" [String h, Number 2] + case field "tx" b of + Just (Array ts) | Just t <- Seq.lookup 0 (Seq.fromList (toList ts)) -> do + txid <- maybe (fail "no txid") return (textField "txid" t >>= hexToTxHash) + v <- case field "vout" t of + Just (Array os) | o : _ <- toList os, Just v <- field "value" o -> return (sats v) + _ -> fail "no coinbase output" + return (OutPoint txid 0, v) + _ -> fail ("No transactions in block " <> T.unpack h) + +-- | Height of the best block of the node. +nodeHeight :: Node -> IO Int +nodeHeight node = + rpc node "getblockcount" [] >>= \case + Number n -> return (round n) + v -> fail ("Unexpected block count: " <> show v) + +------------------------------------------------------------------------------- +-- The stress test +------------------------------------------------------------------------------- + +stress :: Opts -> Ctx -> Node -> String -> Server -> IORef Stats -> Container -> IO () +stress o ctx node redisURL srv stats wc = do + g <- newIOGenM (mkStdGen o.seed) + let (ws, miner) = makeWallets ctx o + minerAddr = keyAddress miner + perFanOut = 1000 + fanOuts = max 1 ((o.blockTxs * 3 `div` 2 + perFanOut - 1) `div` perFanOut) + writeJSON (o.out <> "/config.json") $ + object + [ "txs" .= o.txs, + "wallets" .= o.wallets, + "addresses" .= o.addresses, + "block_txs" .= o.blockTxs, + "batch" .= o.batch, + "connections" .= o.connections, + "wrk_seconds" .= o.wrkSeconds, + "server_rts" .= o.serverRts, + "xpubs" .= map (.xpub) ws + ] + say ("Funding " <> show (length ws) <> " wallets with " <> show (fanOuts * perFanOut) <> " coins") + funded <- generateTo node fanOuts minerAddr + void $ generateTo node 100 minerAddr + coins0 <- fmap concat . forM funded $ \h -> do + (op, v) <- coinbaseOf node h + let n = perFanOut + each = (v - 200000) `div` fromIntegral n + -- every receiving address of every wallet, in turn + targets = take n (cycle [(wi, Seq.index w.receive j) | j <- [0 .. o.addresses - 1], (wi, w) <- zip [0 ..] ws]) + tx = sign ctx (buildTx ctx [op] [(k.script, each) | (_, k) <- targets]) [Coin op v (-1) miner] + errs <- sendRaw node [tx] + forM_ errs $ mapM_ (\e -> fail ("The node refused a funding transaction: " <> show e)) + return [Coin (OutPoint (txHash tx) i) each wi k | (i, (wi, k)) <- zip [0 ..] targets] + void $ generateTo node 1 minerAddr + say "Waiting for the server to sync and cache the xpubs" + waitSynced node srv + forM_ ws $ \w -> getJSON srv ("/xpub/" <> T.unpack w.xpub <> "/balances") + waitFor 120 "the xpubs to be cached" $ do + conn <- Redis.checkedConnect (either error id (Redis.parseConnectInfo redisURL)) + n <- either (const 0) id <$> Redis.runRedis conn (Redis.dbsize) + Redis.disconnect conn + return (n > 0) + writeScripts o + slowlogStart redisURL + stop <- newTVarIO False + start <- getCurrentTime + withFile (o.out <> "/samples.jsonl") WriteMode $ \sh -> + withFile (o.out <> "/wrk.jsonl") WriteMode $ \wh -> do + wlock <- newMVar wh + withAsync (sampler start node srv redisURL stats stop sh) $ \_ -> + withAsync (wrkAll o ws srv wc start stop wlock) $ \_ -> do + (sent, refused) <- withFile (o.out <> "/rounds.jsonl") WriteMode $ \rh -> + rounds o ctx g node ws minerAddr start rh (Seq.fromList coins0) + say "Waiting for the server to catch up" + t0 <- getCurrentTime + waitSynced node srv + catchUp <- (`diffUTCTime` t0) <$> getCurrentTime + atomically (writeTVar stop True) + -- let the last runs of wrk and the sampler finish + threadDelay ((o.wrkSeconds + 3) * 1000000) + say "Comparing cached answers with the database" + checks <- forM ws (consistent srv) + slow <- slowlog redisURL + end <- getCurrentTime + height <- nodeHeight node + writeJSON (o.out <> "/summary.json") $ + object + [ "transactions_sent" .= sent, + "transactions_refused" .= refused, + "height" .= height, + "seconds" .= (realToFrac (end `diffUTCTime` start) :: Double), + "catch_up_seconds" .= (realToFrac catchUp :: Double), + "consistency" .= concat checks, + "redis_slow" .= slow + ] + say ("Done: " <> show sent <> " transactions, " <> show refused <> " refused") + +-- | Make the transactions, a block at a time. Gives how many were sent and +-- how many the node refused. +rounds :: Opts -> Ctx -> IOGenM StdGen -> Node -> [Wallet] -> Text -> UTCTime -> Handle -> Seq Coin -> IO (Int, Int) +rounds o ctx g node ws minerAddr start rh = go 0 (0, 0) + where + total = o.txs + go :: Int -> (Int, Int) -> Seq Coin -> IO (Int, Int) + go r (sent, refused) pool + | sent >= total = return (sent, refused) + | otherwise = do + let n = minimum [o.blockTxs, total - sent, Seq.length pool] + (spend, rest) = Seq.splitAt n pool + when (n == 0) $ fail "No coins left to spend" + t0 <- getCurrentTime + made <- mapM (pay ctx g ws) (toList spend) + -- sign now, not when the transactions are sent + mapM_ (evaluate . force . fst) made + t1 <- getCurrentTime + results <- fmap concat . forM (chunks o.batch (zip (toList spend) made)) $ \chunk -> do + errs <- sendRaw node [tx | (_, (tx, _)) <- chunk] + return (zip chunk errs) + t2 <- getCurrentTime + let accepted = [new | ((_, (_, new)), Nothing) <- results] + back = [c | ((c, _), Just _) <- results] + errors = [e | (_, Just e) <- results] + case errors of + e : _ -> + say $ + unwords + [ "The node refused", + show (length errors), + "transactions, such as", + take 300 (show e) + ] + [] -> return () + void $ generateTo node 1 minerAddr + t3 <- getCurrentTime + height <- nodeHeight node + let sent' = sent + length accepted + appendLine rh $ + object + [ "round" .= r, + "t" .= secs start t3, + "height" .= height, + "sent" .= sent', + "refused" .= length errors, + "sign_ms" .= ms t0 t1, + "submit_ms" .= ms t1 t2, + "mine_ms" .= ms t2 t3 + ] + when (r `mod` 10 == 0) $ + say ("Round " <> show r <> ": " <> show sent' <> " transactions, height " <> show height) + go (r + 1) (sent', refused + length errors) (rest <> Seq.fromList (back <> concat accepted)) + chunks k xs = case splitAt k xs of + ([], _) -> [] + (a, b) -> a : chunks k b + +-- | Wait until the server has the best block of the node. +waitSynced :: Node -> Server -> IO () +waitSynced node srv = + waitFor 1800 "the server to sync" $ do + h <- nodeHeight node + serverHeight srv <&&> (== h) + where + a <&&> f = maybe False f <$> a + +-- | Height of the best block of the server. +serverHeight :: Server -> IO (Maybe Int) +serverHeight srv = + tryAny (getJSON srv "/block/best?notx=true") <&> \case + Right v | Just (Number n) <- field "height" v -> Just (round n) + _ -> Nothing + where + (<&>) = flip fmap + +-- | Compare the cached answers about an xpub with those of the database, +-- for up to a minute, as the cache may still be catching up. +consistent :: Server -> Wallet -> IO [Value] +consistent srv w = + forM paths $ \p -> do + ok <- tryWait (60 :: Int) p + return (object ["xpub" .= w.xpub, "path" .= p, "same" .= ok]) + where + paths = ["", "/balances", "/transactions?limit=100", "/unspent?limit=100"] + base = "/xpub/" <> T.unpack w.xpub + sep p = if '?' `elem` p then "&" else "?" + tryWait n p = do + a <- getJSON srv (base <> p) + b <- getJSON srv (base <> p <> sep p <> "nocache=true") + if a == b || n <= 0 + then return (a == b) + else threadDelay 1000000 >> tryWait (n - 1) p + +------------------------------------------------------------------------------- +-- wrk +------------------------------------------------------------------------------- + +-- | Endpoints that wrk asks about, each rotating over every xpub. +endpoints :: [(String, Text -> Text)] +endpoints = + [ ("summary", \x -> "/xpub/" <> x), + ("balances", \x -> "/xpub/" <> x <> "/balances"), + ("transactions", \x -> "/xpub/" <> x <> "/transactions?limit=100"), + ("unspent", \x -> "/xpub/" <> x <> "/unspent?limit=100"), + ("multiaddr", \x -> "/blockchain/multiaddr?active=" <> x <> "&n=50") + ] + +-- | The script of wrk ("stress/wrk.lua"), copied into the output directory +-- where the container of wrk sees it. It asks for the paths it is given in +-- turn and prints its results as JSON. It is embedded when the program is +-- compiled, so the program finds it wherever it runs. +writeScripts :: Opts -> IO () +writeScripts o = BS.writeFile (o.out <> "/wrk.lua") $(makeRelativeToProject "stress/wrk.lua" >>= embedFile) + +-- | Run wrk on every endpoint at once, over and over, until told to stop. +wrkAll :: Opts -> [Wallet] -> Server -> Container -> UTCTime -> TVar Bool -> MVar Handle -> IO () +wrkAll o ws srv wc start stop lock = go endpoints + where + go [] = return () + go ((name, path) : rest) = withAsync (loop name (map (path . (.xpub)) ws)) $ \_ -> go rest >> waitStop + waitStop = readTVarIO stop >>= \s -> unless s (threadDelay 500000 >> waitStop) + loop name paths = do + s <- readTVarIO stop + unless s $ do + t <- getCurrentTime + let args = + [ "exec", + wc.cid, + wrkBin, + "-t1", + "-c" <> show o.connections, + "-d" <> show o.wrkSeconds <> "s", + "--timeout", + "10s", + "-s", + "/stress/wrk.lua", + srv.url, + "--" + ] + <> map T.unpack paths + (code, out, err) <- readProcessWithExitCode "podman" args "" + let result = case [l | l <- lines out, take 1 l == "{"] of + l : _ | Just (Object r) <- A.decode (BL.fromStrict (C8.pack l)) -> Object r + _ -> object ["failed" .= True, "exit" .= show code, "stderr" .= take 300 err] + withMVar lock $ \h -> + appendLine h (merge (object ["t" .= secs start t, "endpoint" .= name]) result) + loop name paths + merge (Object a) (Object b) = Object (a <> b) + merge a _ = a + +------------------------------------------------------------------------------- +-- Sampling +------------------------------------------------------------------------------- + +-- | Write a sample every second until told to stop: the heights of the node +-- and the server, the CPU and memory of the server, the memory of Valkey, and +-- the StatsD metrics of the server since the last sample. +sampler :: UTCTime -> Node -> Server -> String -> IORef Stats -> TVar Bool -> Handle -> IO () +sampler start node srv redisURL stats stop h = do + hz <- clockTicks + conn <- Redis.checkedConnect (either error id (Redis.parseConnectInfo redisURL)) + let go prevTicks prevTime = do + s <- readTVarIO stop + unless s $ do + threadDelay 1000000 + now <- getCurrentTime + ticks <- cpuTicks srv.pid + rss <- rssKb srv.pid + (heap, lazyFree) <- ghcHeapKb srv.pid + nh <- either (const Nothing) Just <$> tryAny (nodeHeight node) + sh <- serverHeight srv + vm <- valkeyMemory conn + m <- drainStats stats + let seconds = realToFrac (now `diffUTCTime` prevTime) + cpu = fromIntegral (max 0 (ticks - prevTicks)) / fromIntegral hz / seconds * 100 :: Double + appendLine h $ + object + [ "t" .= secs start now, + "node_height" .= nh, + "server_height" .= sh, + "cpu_percent" .= cpu, + "rss_mb" .= (fromIntegral rss / 1024 :: Double), + "heap_mb" .= (fromIntegral heap / 1024 :: Double), + "heap_lazy_free_mb" .= (fromIntegral lazyFree / 1024 :: Double), + "valkey_mb" .= ((/ (1024 * 1024)) . fromIntegral <$> vm :: Maybe Double), + "counters" .= m.counters, + "gauges" .= m.gauges, + "timings" .= HashMap.map timingStats m.timings + ] + go ticks now + t <- getCurrentTime + ticks0 <- cpuTicks srv.pid + go ticks0 t + where + timingStats vs = + let s = sort vs + n = length s + at p = s !! min (n - 1) (floor (p * fromIntegral n :: Double)) + in object ["n" .= n, "p50" .= at 0.5, "p95" .= at 0.95, "max" .= last s, "sum" .= sum s] + +-- | Ticks of the clock of the kernel per second. +clockTicks :: IO Int +clockTicks = do + r <- tryAny (readProcessWithExitCode "getconf" ["CLK_TCK"] "") + return $ case r of + Right (ExitSuccess, o, _) | Just n <- readMaybe o -> n + _ -> 100 + +-- | CPU time of a process, in ticks of the clock of the kernel. +cpuTicks :: Int -> IO Int +cpuTicks pid = do + r <- tryAny (readFile ("/proc/" <> show pid <> "/stat")) + return $ case r of + -- the fields after the name, which is in parentheses and may have spaces + Right s + | fs <- words (drop 2 (dropWhile (/= ')') s)), + length fs > 13 -> + sum (mapMaybe readMaybe [fs !! 11, fs !! 12]) + _ -> 0 + +-- | Resident memory of a process, in KiB. +rssKb :: Int -> IO Int +rssKb pid = do + r <- tryAny (readFile ("/proc/" <> show pid <> "/status")) + return $ case r of + Right s | (v : _) <- [w | l <- lines s, ("VmRSS:" : w : _) <- [words l]], Just n <- readMaybe v -> n + _ -> 0 + +-- | Resident memory of the GHC heap of a process, in KiB: what is resident of +-- the address range that the runtime reserves for its heap, 1 TiB from +-- @0x4200000000@. The rest of the resident memory is outside the heap: +-- RocksDB, buffers of C libraries, stacks and the program itself. A heap that +-- grows while its live data does not is memory the runtime took for a peak +-- and kept, which a heap profile, made of live data, does not show. +-- +-- Also gives how much of it the runtime has given back to the system with +-- @MADV_FREE@ (@LazyFree@): free for the kernel to take when it needs memory, +-- but counted as resident until it does. +ghcHeapKb :: Int -> IO (Int, Int) +ghcHeapKb pid = do + r <- tryAny (readFile ("/proc/" <> show pid <> "/smaps")) + return $ case r of + Left _ -> (0, 0) + Right s -> (go "Rss:" False 0 (lines s), go "LazyFree:" False 0 (lines s)) + where + base = 0x4200000000 :: Integer + top = base + 2 ^ (40 :: Int) + go _ _ n [] = n + go key inHeap n (l : ls) + | (range : _) <- words l, + (a, '-' : _) <- break (== '-') range, + [(start, "")] <- readHex a = + go key (start >= base && start < top) n ls + | inHeap, (k : v : _) <- words l, k == key, Just x <- readMaybe v = go key inHeap (n + x) ls + | otherwise = go key inHeap n ls + +-- | Memory used by Valkey, in bytes. +valkeyMemory :: Redis.Connection -> IO (Maybe Integer) +valkeyMemory conn = + Redis.runRedis conn Redis.info <&&> \case + Right s -> + case [v | l <- C8.lines s, Just v <- [C8.stripPrefix "used_memory:" l]] of + v : _ -> fst <$> C8.readInteger v + [] -> Nothing + Left _ -> Nothing + where + a <&&> f = f <$> a + +-- | Make Valkey log every command that takes 10 ms or more, keeping all of +-- them: a long script blocks every client of Redis, every server included. +slowlogStart :: String -> IO () +slowlogStart url = withRedis url $ \conn -> Redis.runRedis conn $ do + send ["CONFIG", "SET", "slowlog-log-slower-than", "10000"] + send ["CONFIG", "SET", "slowlog-max-len", "100000"] + send ["SLOWLOG", "RESET"] + where + send args = void (Redis.sendRequest args :: Redis.Redis (Either Redis.Reply Redis.Reply)) + +-- | The commands that took 10 ms or more: when, how long in milliseconds, +-- the command, and how many arguments it had. For a script of the cache, +-- also its name and, for a commit, whether it was of a full reload. +-- +-- The slow log keeps the first 32 arguments of a command, each cut to 128 +-- bytes, and ends the list with how many it left out. That is enough: the +-- first argument of an EVAL is the script, whose first line names it (as +-- @commitScript@), and the number of arguments of a commit grows with the +-- size of the change. +slowlog :: String -> IO [Value] +slowlog url = withRedis url $ \conn -> + Redis.runRedis conn (Redis.sendRequest ["SLOWLOG", "GET", "100000"]) <&&> \case + Right (Redis.MultiBulk (Just entries)) -> mapMaybe entry entries + _ -> [] + where + a <&&> f = f <$> a + entry (Redis.MultiBulk (Just (_ : Redis.Integer ts : Redis.Integer us : Redis.MultiBulk (Just reply) : _))) = + let args = [decodeUtf8 b | Redis.Bulk (Just b) <- reply] + script = case args of + _ : body : _ -> take 1 [w | w <- T.words body, "Script" `T.isSuffixOf` w] + _ -> [] + in Just . object $ + [ "time" .= ts, + "ms" .= (fromIntegral us / 1000 :: Double), + "command" .= T.toUpper (T.take 24 (mconcat (take 1 args))), + "args" .= argCount args + ] + <> ["script" .= s | s <- script] + -- ARGV[8] of a commit is the time of a full reload, or empty + <> ["full" .= not (T.null f) | script == ["commitScript"], f <- take 1 (drop 10 args)] + entry _ = Nothing + -- the arguments kept, the last of which may say how many were left out: + -- "... (2048 more arguments)" + argCount args = case reverse args of + l : kept + | Just rest <- T.stripPrefix "... (" l, + [(n, _)] <- reads (T.unpack rest) -> + length kept + n :: Int + _ -> length args + +withRedis :: String -> (Redis.Connection -> IO a) -> IO a +withRedis url = bracket (Redis.checkedConnect (either error id (Redis.parseConnectInfo url))) Redis.disconnect + +------------------------------------------------------------------------------- +-- StatsD +------------------------------------------------------------------------------- + +-- | Metrics received since they were last drained: counters added up, +-- gauges at their last value, and every timing. +data Stats = Stats + { counters :: !(HashMap Text Double), + gauges :: !(HashMap Text Double), + timings :: !(HashMap Text [Double]) + } + +-- | Receive the StatsD metrics of the server on a UDP port of the loopback +-- interface while an action runs. +withStatsd :: (Int -> IORef Stats -> IO a) -> IO a +withStatsd act = + bracket (Socket.socket Socket.AF_INET Socket.Datagram Socket.defaultProtocol) Socket.close $ \s -> do + Socket.bind s (Socket.SockAddrInet 0 (Socket.tupleToHostAddress (127, 0, 0, 1))) + port <- fromIntegral <$> Socket.socketPort s + ref <- newIORef (Stats HashMap.empty HashMap.empty HashMap.empty) + let receive = do + bs <- SocketB.recv s 65535 + forM_ (C8.lines bs) $ \l -> forM_ (parseLine l) $ \m -> + atomicModifyIORef' ref (\st -> (add m st, ())) + receive + withAsync receive $ \_ -> act port ref + where + add (k, v, t) st = case t of + 'c' -> st {counters = HashMap.insertWith (+) k v st.counters} + 'g' -> st {gauges = HashMap.insert k v st.gauges} + _ -> st {timings = HashMap.insertWith (<>) k [v] st.timings} + +-- | A StatsD line, @key:value|type@ with an optional @|\@rate@: the key +-- without the prefix of the server, the value (scaled up by the rate for a +-- sampled counter), and the first letter of the type. +parseLine :: C8.ByteString -> Maybe (Text, Double, Char) +parseLine l = do + let (k, rest) = C8.break (== ':') l + (v, t, rate) <- case C8.split '|' (C8.drop 1 rest) of + [v, t] -> Just (v, t, 1) + [v, t, r] | Just ('@', x) <- C8.uncons r -> (v,t,) <$> readMaybe (C8.unpack x) + _ -> Nothing + x <- readMaybe (C8.unpack (C8.dropWhile (== '+') v)) + c <- fst <$> C8.uncons t + let key = T.replace "stress.btcreg." "" (decodeUtf8 k) + return (key, if c == 'c' then x / rate else x, c) + +-- | Take the counters and timings received since the last call; gauges +-- keep their values. +drainStats :: IORef Stats -> IO Stats +drainStats ref = atomicModifyIORef' ref $ \st -> (st {counters = HashMap.empty, timings = HashMap.empty}, st) + +------------------------------------------------------------------------------- +-- Helpers +------------------------------------------------------------------------------- + +say :: String -> IO () +say s = hPutStrLn stderr ("stress: " <> s) >> hFlush stderr + +-- | Try a check every quarter of a second, for up to some seconds. +waitFor :: Int -> String -> IO Bool -> IO () +waitFor secs' what check = go (secs' * 4) + where + go n = + check >>= \case + True -> return () + False + | n <= 0 -> fail ("Timed out waiting for " <> what) + | otherwise -> threadDelay 250000 >> go (n - 1) + +secs :: UTCTime -> UTCTime -> Double +secs a b = realToFrac (b `diffUTCTime` a) + +ms :: UTCTime -> UTCTime -> Double +ms a b = 1000 * secs a b + +appendLine :: Handle -> Value -> IO () +appendLine h v = BL.hPut h (encode v <> "\n") >> hFlush h + +writeJSON :: FilePath -> Value -> IO () +writeJSON path = BL.writeFile path . encode diff --git a/stress/wrk.lua b/stress/wrk.lua new file mode 100644 --- /dev/null +++ b/stress/wrk.lua @@ -0,0 +1,32 @@ +-- The script of wrk for the stress test (stress/Main.hs). It asks for the +-- paths given after "--" on the command line in turn, and when wrk is done it +-- prints one line of JSON with the results, latencies in microseconds: +-- +-- wrk -s wrk.lua http://server -- /xpub/a /xpub/b +local paths = {} +local i = 0 + +init = function(args) + paths = args +end + +request = function() + i = i % #paths + 1 + return wrk.format("GET", paths[i]) +end + +done = function(summary, latency, requests) + local e = summary.errors + local fields = { + '"requests":' .. summary.requests, + '"duration_us":' .. summary.duration, + '"errors":' .. (e.connect + e.read + e.write + e.timeout), + '"non2xx":' .. e.status, + '"p50_us":' .. latency:percentile(50), + '"p90_us":' .. latency:percentile(90), + '"p99_us":' .. latency:percentile(99), + '"max_us":' .. latency.max, + '"mean_us":' .. string.format("%.1f", latency.mean), + } + io.write("{" .. table.concat(fields, ",") .. "}\n") +end diff --git a/swagger.yaml b/swagger.yaml new file mode 100644 --- /dev/null +++ b/swagger.yaml @@ -0,0 +1,8042 @@ +# Long values, such as the hexadecimal of transactions and blocks and the +# xpubs in the examples, are split into pieces of equal width with escaped line +# breaks in double quotes, which join the pieces with nothing between them, so +# that every line stays under 120 columns. An xpub used as a key is split the +# same way, as an explicit key ("? "). +openapi: 3.0.0 + +servers: + - url: 'https://api.haskoin.com/bch/' + - url: 'https://api.haskoin.com/btc/' + - url: 'https://api.haskoin.com/bchtest4/' + - url: 'https://api.haskoin.com/btctest4/' + +info: + version: &version 1.9.0 + title: Haskoin + contact: + name: JP Rupp + url: https://github.com/jprupp + email: jprupp@protonmail.ch + license: + name: MIT + url: https://github.com/jprupp/haskoin-store/blob/master/haskoin-store/LICENSE + description: | + Haskoin Store indexes the Bitcoin (BTC) and Bitcoin Cash (BCH) block chains + and answers the questions that a node cannot answer on its own: what is the + balance of this address, which transactions belong to this wallet, which + outputs can it spend. It connects to the peer-to-peer network itself, keeps + its indices up to date with every block and every unconfirmed transaction, + and serves them here. + + The servers of this reference are the public instance at api.haskoin.com, one per + network: `btc`, `bch`, and their test networks `btctest4` and `bchtest4`. The + same API is served by any Haskoin Store you run yourself. + + ## The basics + + - **Amounts** of coins are whole numbers of satoshis (1 coin is 100,000,000 + satoshis), never decimal numbers of coins: floating-point numbers cannot + hold every satoshi amount exactly, and a balance that is off by one + satoshi is a bug that is hard to find. Only prices in other currencies, + in the Blockchain.info endpoints, are decimal. + - **Hashes** of blocks and transactions are hexadecimal, in the byte order + that nodes and block explorers display, so they can be copied between them + and this API. + - **Scripts and serialized data** are hexadecimal. + - **Times** are Unix timestamps, in seconds. + - **Addresses** are written as the network writes them: Base58 or Bech32 on + BTC, CashAddr on BCH. + + ## Lists are newest first + + Every list of transactions or unspent outputs starts with the newest: + unconfirmed transactions first, by the time this server first saw them, then + confirmed ones, from the highest block down, and within a block from the last + transaction to the first. + + This is the order in which wallets and explorers show activity, and the + database is laid out in that order, so the first page of any list is a single + lookup however long the history is. + + ## Paging + + Lists take three parameters: + + - `limit`: how many items to return. Without it the server returns its + default number (100, unless the operator changed it). There is a maximum, + lower for lists of full transactions, which are much larger; `limit=0` + asks for that maximum. + - `height`: where the page starts. It can be: + - a **transaction id**: the page starts at that transaction, which is + included; + - a **block hash**: the page starts at that block; + - a **block height**: the page starts at transactions confirmed at or below + that height; + - a **Unix time**: the page starts at the last block mined at or before + that time. + + Numbers up to 1,230,768,000 are heights and larger ones are times. That + number is midnight on 1 January 2009, before the first block, so no time + of a block is mistaken for a height, and no chain will reach that height. + - `offset`: how many items to skip after the start. The server has a + maximum (50,000, unless the operator changed it). + + **To get the next page, pass the id of the last transaction you received as + `height`, and `offset=1` to skip it.** An offset counts from the newest item, + so every new transaction shifts every page by one, and a deep offset makes the + server step over all the items before it. A transaction id is a fixed point: + pages do not shift, and the server finds the start with one lookup however + far back it is. The maximum offset is there because deep offsets are slow. + + ## Formats + + - **JSON** by default, without spaces, to keep responses small. + - **Pretty JSON** with `pretty=true`, indented for people to read. + - **Binary** with the header `Accept: application/octet-stream`: the compact + serialization that the Haskell client in + [haskoin-store-data](https://github.com/jprupp/haskoin-store-data) + decodes. It is smaller and faster to decode than JSON. "Binary format" + below gives every byte of it. + + Endpoints that end in `/raw` return data serialized as in the peer-to-peer + protocol, in hexadecimal inside JSON (`{"result": "0100…"}`), or as bytes + with the binary format. + + ## Parameters are checked + + Every endpoint lists the parameters it accepts, and refuses a request with + any other, with 400 and a message that names it: + + ```json + {"error": "user-error", "message": "Unknown parameter: limt"} + ``` + + A value that the endpoint cannot read is refused the same way, such as + `limit=ten`, `notx=yes` or `derive=Legacy`. Without this, a misspelt + parameter or a value the server does not understand would be ignored, and + the client would get an answer to a question it did not ask, with nothing + to tell it so. Requests are checked before anything is done, so a refused + request has no effect. + + One thing is not refused, because it is not a mistake: a `limit` above the + server's maximum is lowered to it, as a client cannot know the maximum of + every server. Names of parameters are case-sensitive. + + ## Errors + + An error is a JSON object with a stable `error` code, for programs, and a + `message`, for people: + + ```json + {"error": "user-error", "message": "Invalid value for parameter limit: ten"} + ``` + + | Status | `error` | When | + | --- | --- | --- | + | 400 | `user-error`, `bad-request` | A parameter or the body is wrong; the message says which. | + | 404 | `not-found-or-invalid-arg` | The thing does not exist, or a value in the path is not valid. | + | 409 | `multiple-tx-index` | A short transaction number matches several transactions. | + | 500 | `server-error` | Something went wrong on the server; it is logged there. | + | 503 | | From `/health`: the server is not ready. | + | 503 | `behind-fleet` | The server is one of a fleet and does not have the block that the fleet answers from; another server of the fleet does. | + + A request that asks for the binary format gets its errors in binary too: + see "Binary format". + + `/health` also answers 203 for a server that works but cannot reach its + Redis; see there. + + A value in the path that does not parse, such as a misspelt address, gives + 404 rather than 400. Paths are matched by the shape of what is in them, and + a segment that does not parse may belong to another endpoint (`/block/best` + and `/block/{block}` share a prefix), so the server tries the others, and + when none matches it answers that there is nothing there. Query parameters + are not ambiguous, so a bad one gives 400, with its name in the message. + + A 409 comes only from the Blockchain.info endpoints, which can name a + transaction by a short number; the error lists the matching ids in `txids`. + + The codes `server-timeout` and `request-too-large` are part of the format, for + clients that decode it, but this version of the server does not send them. + + ## Unconfirmed transactions + + The mempool is indexed like the chain. A payment shows up in balances and + histories as soon as this server sees it on the network, with + `"block": {"mempool":