diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,6 +6,78 @@ ## [Unreleased] +## [1.9.1] - 2026-11-11 + +### Changed + +- **The health check runs every second**, where it ran every thirty, and + at once when the store has a new best block. `/health` answers from the + last result, so a load balancer and a fleet acted on news of up to half + a minute ago. Redis is asked every five seconds. + `--health-check-interval` still sets the interval. + +- **Log levels say who has the problem.** An error in the log is now + something wrong with the store or its database, so that an alert on + errors is worth having. The README has a table of the levels. + - A transaction from a peer that the store refuses (an orphan, a double + spend, one without funds, one already confirmed) is logged for + debugging. These were errors, several a minute on a healthy server. + - A request answered 4xx or 503 is logged for debugging, like a + successful one. Only a 500 is an error. + - A peer that times out or sends a block that was not asked for is a + warning. + - Redis or the price service not answering is a warning: the store + goes on without them, and `/health` says so. + - **An outage of Redis is logged once when it starts and once when it + is over** (`Haskoin.Store.Outage`), and for debugging in between. The + loops of a fleet and the worker of the cache each logged every failed + attempt, every second or two, and nothing said when Redis was back. + `memberLoop`, `memberCacheLoop` and `memberEvents` no longer take a + function to tell of a failure. + - Each transaction imported into the mempool is logged for debugging, + where it was information. + - With haskoin-node 2.5.1: a peer that hangs up or misbehaves is not an + error, and the comings and goings of peers are logged for debugging. + +### Fixed + +- **A fleet could stop answering for good after an outage.** A server goes + through 50 blocks at most to tell the shared mempool what they did, and + further than that it may only empty the mempool, which Redis allowed to + a server that was alone. Two or more servers that came back together + more than 50 blocks past the block that the fleet last answered from + each kept the other from moving on, and every request was answered 503 + `behind-fleet` from then on. + - Any server may now move the fleet when the way is too long for all of + them (`fleetRestart`, `wayBetween`): the shared mempool is emptied, a + counter in Redis says so (`fleet:restarts`), and every server that + sees it offers its whole mempool again. A server did not notice + before that another one had emptied the mempool. + - A test builds the stuck fleet on purpose, with two members of one + fleet (`Haskoin.Store.Fleet.MemberSpec`). +- **A server that had just started took a turn in its fleet before its + first health check**, reported the blocks that it had then, and with no + other server there moved the fleet to them. It now waits for the check. + +### Added + +- **A change of health is logged**: a warning with what is wrong when + `/health` stops answering 200, and a line when it does again; the same + for Redis. Nothing said so before but the 503s of the requests. +- **An access log**, off by default: `--access-log` (`ACCESS_LOG`) logs + every request with the address of the client, the status and the time + it took. +- With `--debug`, a member of a fleet says why its report was not taken + and what became of each attempt to move the fleet's block. +- `HASKOIN_TEST_LOG` prints the time of each line, and the lines of the + two stores of the fleet test under their names. +- **A slow request is logged as a warning**, with how long it took: + `--slow-request` (`SLOW_REQUEST`), five seconds by default, 0 for never. +- `stress/results/2026-11-10/`: the results of a full default stress run + on version 1.9.0, with a comparison against the run of the day before on + 1.8.1. A cache reload takes 234 ms on average where it took 2,448, and + no longer grows with the xpub. + ## [1.9.0] - 2026-11-10 ### Added diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -283,16 +283,18 @@ ### 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. +Start the store with `--redis` and a Redis (or Valkey) server. +- **Large xpubs are cached** after their first query and answered from + Redis, transactions in full included. Large means at least + `--redis-min-addrs` used addresses, or at least `--redis-min-txs` + transactions. +- **Several stores can share one Redis.** They keep each other's cache up + to date. +- 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 +([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 @@ -335,6 +337,7 @@ | `--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) | +| `--slow-request` | `SLOW_REQUEST` | `5` | Seconds a request may take before the log warns of it (0 = never) | | `--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 | @@ -381,6 +384,11 @@ 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. +- **After a long outage** the fleet starts its shared mempool again. When + the servers come back more than 50 blocks past the block that the fleet + last answered from, the first of them moves the fleet there, empties + the shared mempool, and all offer their unconfirmed transactions again. + The log has a warning when it happens. - **`/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, @@ -391,16 +399,14 @@ `/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. + cache of a server alone. Set them the same on every server. + - 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 along. + 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. + - A request about a wallet of 464 addresses and 19,499 transactions + takes 1.3 to 2.2 milliseconds with it, 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`. @@ -414,7 +420,7 @@ | `--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 | +| `--health-check-interval` | `HEALTH_CHECK_INTERVAL` | `1` | Seconds between checks; there is one at each new block too | ### Metrics and logging @@ -425,6 +431,7 @@ | `--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 | +| `--access-log` | `ACCESS_LOG` | off | Log every request, with the address of the client and the time it took | | `--debug` | `DEBUG` | off | Verbose logging | ### RocksDB @@ -561,206 +568,279 @@ ``` - **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. +- The **block store** downloads blocks from one peer at a time and mempool + transactions from all of them, and imports them. 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 **web server** answers from RocksDB, and from Redis for what is + cached there. -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. +### The database -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 chain and the mempool are kept apart. -The database layout is described in `Haskoin.Store.Database.Types`. +- **The chain's data is written once and is the same on every server** that + has the same blocks. A confirmed transaction has the time of its block. + What spends its outputs is under keys of its own, so its record never + changes. +- **Unconfirmed transactions live in an area of their own**, and are applied + on top of the chain when a query is answered. Nothing the mempool does + changes the chain's data. +- **A transaction that leaves the mempool unconfirmed is forgotten**: it was + replaced, double-spent by a block, or too old. The API answers 404 for + it. +- **Each request reads one snapshot** of the database, so everything in an + answer is of the same moment. -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. +`docs/layered-database.md` has the reasons, the measurements and the tests. +The layout of the keys is described in `Haskoin.Store.Database.Types`. -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. +### Upgrading an existing database -- **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. +This is version 22 of the database. The store migrates an older database +the first time it opens it. **There is no way back**: an older store +refuses the database afterwards, so take a copy first. -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. +| From | What the migration does | How long | +| --- | --- | --- | +| 20 | Moves the mempool to its own area | Seconds to minutes | +| 21 | Reads every transaction and writes nearly every one again | Many hours for Bitcoin | -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 second step is the long one. Nothing lists the records that need a +change, and nearly all do. -- 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. +- **Time:** a database of Bitcoin has more than a billion transactions. + The store does not start until it is done. The log says how far it is + every million transactions. +- **Disk:** it needs room for a second copy of the transactions, until + RocksDB has compacted the first away. +- **Interrupted,** it starts again and skips what is done. +- **Deleted transactions** that an old database still holds are left where + they are and ignored. Finding them would mean reading everything again. +What changed for clients in version 22: + +- A confirmed transaction that the server first saw in its mempool used to + keep that time. Now every server gives the time of the block. +- Reading one confirmed transaction in full takes a second key: 18 + microseconds where it took 11.5. Lists by address and by xpub cost the + same as before. + +### Extended public keys + +**The gap.** 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`. 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. + +**The type of address.** An xpub does not record which kind of address its +wallet derives, so a request names it with `derive`. + +- If the xpub has no transactions of the kind asked for, the store looks at + the first `--xpub-gap-init` addresses of the other kinds. +- 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 never on + networks without SegWit, which have one kind of address. + +### The cache of a server alone + +With `--redis`, the cache (`Haskoin.Store.Cache`) keeps large xpubs in +Redis: their balances, transactions, unspent outputs and the bodies of +their transactions. Without Redis, xpub queries read RocksDB directly. + +- **It reads the database, it does not guess.** When a block, a mempool + transaction or a reorganisation touches a cached xpub, the store reads + what changed from RocksDB, with the same queries that answer uncached + requests, and writes the differences to Redis in one Lua script. +- **An update costs the size of the change**, not of the xpub. Redis + answers one client at a time, so this is what keeps it responsive. +- **The script writes nothing if the entry changed since it was read**, so + an entry is always what the database says. +- **It reads the whole xpub when it cannot be sure** that the entry has + every earlier change: when it first caches it, when the entry is more + than a block behind, when an address enters or leaves the gap, when a + balance does not add up, and every five to ten minutes in any case. +- **Stores that share a Redis** claim each change, so it is applied once. A + store never replaces an entry that knows more than its own database, and + a store that is catching up does no cache work. +- **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, +compiled into the library. The ways an entry could still come to differ +from the database unnoticed, and what would rule them out, are in +`docs/cache-consistency.md`. + +### The cache of a fleet + +A fleet (`--fleet`) has a cache 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; +- what the shared pool has for them, which the pool's own script writes as + it changes the pool. + +The first follows from the chain, so any server writes the same. 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 and the tests. + +### Where the code is + +| Module | What it does | +| --- | --- | +| `Haskoin.Store.BlockStore` | Downloads and imports blocks and mempool transactions | +| `Haskoin.Store.Logic.Layered` | The rules that import blocks and transactions | +| `Haskoin.Store.Database.Mempool` | The keys of the mempool area, and what it does to balances | +| `Haskoin.Store.Database.Query.Layered` | The queries over both areas, each on a snapshot | +| `Haskoin.Store.Database.Migrate` | The migrations from versions 20 and 21 | +| `Haskoin.Store.Cache` | The Redis cache of a server alone | +| `Haskoin.Store.Fleet.Member`, `Haskoin.Store.Fleet.XPub` | A fleet, and its cache | +| `Haskoin.Store.Web`, `Haskoin.Store.Web.Events` | The web server, and `/events` | + 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. +`Haskoin.Store.Database.Query`) stay in the library as a reference. The +tests hold the new ones to their results, operation by operation and page +by page. 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.*`: +### Health - | 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 | +`/health` returns the result of the latest check as JSON. Point your load +balancer at it. - 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 +| Status | Meaning | +| --- | --- | +| 200 | Every check passes | +| 203 | Healthy, but its Redis does not answer | +| 503 | A check fails; the body says which | + +The check runs every second, and at once when a block arrives, so what +`/health` answers is at most a second old. Redis is asked every five +seconds. + +The checks are: how far the index is behind the headers, the age of the +last block and of the last transaction, the transactions waiting to be +imported, and the connected peers. + +**Without its Redis**, a store that has a cache goes on answering from its +own database: + +- `/health` says 203, 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. The store tries Redis again at every health check. +- Load balancers take 203 for healthy, so the store stays in rotation. + Alert on anything but 200 to hear of it. + +**In a fleet** (`--fleet`), a server that does not have the block that the +fleet answers from can answer any request with 503 and +`{"error": "behind-fleet"}`. Have the load balancer try another server, and +alert if one keeps saying it: its `/health` will say why. + +### StatsD + +With `--statsd`, the store reports: + +| Prefix | What | +| --- | --- | +| `web.*` | Timing of every kind of request | +| `db.*` | Database reads | +| `cache.*` | Cache hits, misses, reloads and full reloads | +| `store.*` | Block and header heights, mempool size and other gauges | +| `fleet.cache.*` | What a server of a fleet does with the fleet's cache of xpubs | + +The metrics of the fleet's 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 says why each time. +- With `--debug` the log also has a line for each entry built and each + block that the cache was brought to. + +### Database statistics + +`/dbstats` returns the memory that RocksDB uses for each column family, and +RocksDB's own statistics, as text. + +### Memory + +The resident memory of the store is its GHC heap plus RocksDB. + +- **RocksDB:** the block cache and memtables fill up to `--block-cache-mb` + and `--write-buffer-mb`, then stay there. +- **The heap** gives memory back to the system as soon as it no longer + needs it. The executable is built with + `--disable-delayed-os-memory-return` for that. Without the flag, Linux + keeps counting returned memory as resident until it needs it, and the + heap looks as if it never shrinks after a peak. +- If you build the store some other way, pass + `+RTS --disable-delayed-os-memory-return -RTS` yourself. +- **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: ...`. +### Logs + +Logs go to standard error, one line per message, tagged with the component, +such as `[Info#BlockStore] Best block: ...`. + +| Level | What it is for | +| --- | --- | +| Error | Something wrong with the store or its database. Alert on these | +| Warn | Something unusual that the store dealt with: a misbehaving peer, no peers left, Redis or the price service not answering, a block reverted, the shared mempool of a fleet started again | +| Info | Milestones: start-up, each new best block, migrations, the mempool pruned | +| Debug | Everything else, with `--debug`: each peer, each transaction, each request | + +What the log says about the server itself, without `--debug`: + +- **Health.** One line when `/health` changes: `No longer healthy: 5 blocks + behind the headers` as a warning, and `Healthy again`. A store that is + still syncing says `Not healthy yet` once, which is not a warning. +- **Slow requests.** A warning for a request that took `--slow-request` + seconds or more to answer, with the request and how long it took. The + stream of events is left out. +- **Every request**, with `--access-log`, which is off by default: + `203.0.113.7 GET /block/best HTTP/1.1: 200 OK, 0.4 ms`. A public + server usually has a proxy in front that keeps this log better. The + address is the first of `X-Forwarded-For` when a proxy sent one. + +An outage of Redis is one warning when it starts, `Could not … Going on +without`, and one line when it is over, `Can … again`. The attempts in +between are logged for debugging. + +Nothing that a peer or a client does is an error. A transaction that the +store refuses (an orphan, a double spend), a request with a bad parameter +or for something unknown, and a peer that hangs up are all ordinary on a +public network, and are logged for debugging. + ## 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 @@ -769,21 +849,26 @@ 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) + r <- apiCall ctx cfg (GetAddrBalance addr) print r ``` +`apiCall` answers `Right` the result or `Left` an error. `apiEvents` +listens to `/events`, and `apiEventsAfter` takes up from an event. + 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. +Or embed the indexer in your own program with `haskoin-store`: +- `withStore` starts the node, the block store and the cache from a + `StoreConfig`. +- The functions of `Haskoin.Store.Database.Query.Layered` query its + database in `IO`, on a view 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 @@ -845,23 +930,31 @@ ### 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. +works hard. +What it runs: + +1. 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. +2. A few wallets, whose keys the stress program (`stress/Main.hs`) holds, + make hundreds of thousands of transactions between them. The program + signs them and sends them to the node in batches, with a block after + each batch. +3. Every transaction changes two cached xpubs, so the cache reloads them + over and over. Meanwhile wrk asks the server about the xpubs on five + endpoints: summary, balances, transactions, unspent outputs and + multiaddr. +4. At the end it compares the cached answers with those of the database. + +`scripts/stress-report.py` then writes `OUT_DIR/report.md`, with: + +- how fast the transactions went in, and how far the server fell behind; +- how many reloads the cache did, how many read the whole xpub, and how + long they took as the xpubs grew; +- the CPU and memory of the server, and the memory of Valkey; +- the commands that blocked Redis for 10 ms or more, from its slow log; +- 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 @@ -932,5 +1025,4 @@ ## License -Haskoin Store is released under the -[MIT License](https://github.com/jprupp/haskoin-store/blob/master/haskoin-store/LICENSE). +Haskoin Store is released under the [MIT License](LICENSE). diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -128,6 +128,7 @@ noBlockchainInfo :: !Bool, noXPub :: !Bool, healthCheckInterval :: !Int, + accessLog :: !Bool, tlsCert :: !String, tlsKey :: !String, bloom :: !Bool, @@ -220,7 +221,9 @@ noXPub <- env "NO_XPUB" False parseBool healthCheckInterval <- - env "HEALTH_CHECK_INTERVAL" 30 readMaybe + env "HEALTH_CHECK_INTERVAL" 1 readMaybe + accessLog <- + env "ACCESS_LOG" False parseBool bloom <- env "BLOOM" True parseBool noWeb <- @@ -264,6 +267,8 @@ env "BLOCK_TIMEOUT" d.blockTimeout readMaybe txTimeout <- env "TX_TIMEOUT" d.txTimeout readMaybe + slowRequest <- + env "SLOW_REQUEST" d.slowRequest readMaybe return WebLimits {..} -- | Names of the supported networks, separated by pipes. @@ -425,6 +430,13 @@ <> helpEnv "TX_TIMEOUT" "Last tx received health timeout" <> showDefault <> value c.webLimits.txTimeout + slowRequest <- + option auto $ + metavar "SECONDS" + <> long "slow-request" + <> helpEnv "SLOW_REQUEST" "Warn in the log of requests that take this long (0 = never)" + <> showDefault + <> value c.webLimits.slowRequest return WebLimits {..} redis <- flag c.redis True $ @@ -580,9 +592,13 @@ option auto $ metavar "SECONDS" <> long "health-check-interval" - <> helpEnv "HEALTH_CHECK_INTERVAL" "Background check update interval" + <> helpEnv "HEALTH_CHECK_INTERVAL" "Seconds between health checks; there is one at each new block too" <> showDefault <> value c.healthCheckInterval + accessLog <- + flag c.accessLog True $ + long "access-log" + <> helpEnv "ACCESS_LOG" "Log every request, with the address of the client and the time it took" tlsCert <- strOption $ metavar "FILE" @@ -749,6 +765,7 @@ noXPub = cfg.noXPub, noBlockchainInfo = cfg.noBlockchainInfo, healthCheckInterval = cfg.healthCheckInterval, + accessLog = cfg.accessLog, tls = case (cfg.tlsCert, cfg.tlsKey) of ("", "") -> Nothing ("", _) -> error "--tls-key needs --tls-cert" diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.hs @@ -144,6 +144,7 @@ noXPub = False, noBlockchainInfo = False, healthCheckInterval = 30, + accessLog = False, tls = Nothing, logger = quiet } diff --git a/haskoin-store.cabal b/haskoin-store.cabal --- a/haskoin-store.cabal +++ b/haskoin-store.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: haskoin-store -version: 1.9.0 +version: 1.9.1 synopsis: Storage and index for Bitcoin and Bitcoin Cash 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 @@ -74,6 +74,7 @@ Haskoin.Store.Logic Haskoin.Store.Logic.Layered Haskoin.Store.Manager + Haskoin.Store.Outage Haskoin.Store.Web Haskoin.Store.Web.Docs Haskoin.Store.Web.Events @@ -107,7 +108,7 @@ , 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-node >=2.5.1 && <2.6 , haskoin-store-data ==1.11.* , hedis >=0.16.4 && <0.17 , http-types >=0.12.6 && <0.13 @@ -172,7 +173,7 @@ , 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-node >=2.5.1 && <2.6 , haskoin-store-data ==1.11.* , hedis >=0.16.4 && <0.17 , http-types >=0.12.6 && <0.13 @@ -235,7 +236,7 @@ , 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-node >=2.5.1 && <2.6 , haskoin-store , haskoin-store-data ==1.11.* , hedis >=0.16.4 && <0.17 @@ -288,6 +289,7 @@ Haskoin.Store.IntegrationSpec Haskoin.Store.Logic.LayeredSpec Haskoin.Store.LogicSpec + Haskoin.Store.OutageSpec Haskoin.Store.TestBlocks Haskoin.Store.Web.EventsSpec Haskoin.Store.Web.RouterSpec @@ -324,7 +326,7 @@ , 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-node >=2.5.1 && <2.6 , haskoin-store , haskoin-store-data ==1.11.* , hedis >=0.16.4 && <0.17 @@ -391,7 +393,7 @@ , 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-node >=2.5.1 && <2.6 , haskoin-store , haskoin-store-data ==1.11.* , hedis >=0.16.4 && <0.17 @@ -455,7 +457,7 @@ , 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-node >=2.5.1 && <2.6 , haskoin-store , haskoin-store-data ==1.11.* , hedis >=0.16.4 && <0.17 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 @@ -594,7 +594,7 @@ Requested -> getBlockNode self blockhash >>= \case Nothing -> do - logError self $ + logWarn self $ "Peer " <> peer.label <> " sent unknown block " @@ -615,7 +615,7 @@ blockhash = headerHash header hexhash = blockHashToHex blockhash refuse who = do - logError self $ + logWarn self $ who <> " " <> peer.label @@ -768,7 +768,7 @@ seconds = floor (utcTimeToPOSIXSeconds time) new_mempool_tx = do t <- newMempoolTx wr tx seconds - logAt LevelInfo block_read.config.logger $ + logAt LevelDebug block_read.config.logger $ bool "Already have" "Imported" t <> " tx " <> txHashToHex (txHash tx) @@ -881,7 +881,7 @@ Sync.timedOut self.config.peerTimeout now <$> readTVarIO self.sync >>= \case Nothing -> return () Just p -> do - logError self $ "Syncing peer timeout: " <> p.label + logWarn self $ "Syncing peer timeout: " <> p.label killPeer p -- | Revert blocks until the best block in the database is in the main chain of headers. 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 @@ -203,6 +203,7 @@ import Haskoin.Store.Database.Query qualified as Q import Haskoin.Store.Database.Query.Layered qualified as L import Haskoin.Store.Database.Reader (DatabaseReader (..)) +import Haskoin.Store.Outage (Outage, attempt, attempting, newOutage) import NQE (Inbox, Publisher, receive, withSubscription) import System.Metrics.StatsD ( StatCounter, @@ -230,7 +231,6 @@ readIORef, readTVar, timeout, - tryAny, withAsync, writeIORef, writeTVar, @@ -316,7 +316,10 @@ -- 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)) + lost :: !(IORef (HashSet TxHash)), + -- | whether the last thing that the worker tried failed, so that an + -- outage of Redis is logged once + outage :: !Outage } -- | What a store did to the cache since it started. @@ -366,6 +369,7 @@ counters <- newIORef (CacheCounters 0 0 0) touched <- newIORef HashMap.empty lost <- newIORef HashSet.empty + outage <- newOutage metrics <- mapM newCacheMetrics cfg.stats let cache = Cache @@ -381,7 +385,8 @@ counters = counters, jobs = jobs, touched = touched, - lost = lost + lost = lost, + outage = outage } withSubscription pub $ \events -> withAsync (listener cache events) $ \a1 -> @@ -1257,7 +1262,7 @@ return (reverse xs) synced <- inSync c if synced - then handleAny (\e -> log' c LevelError ("Cache: " <> cs (show e))) (work c lastBest js) + then void (attempt c.outage (log' c) "update the cache" (work c lastBest js)) else releaseClaims c (concat [ks | JobHeld _ _ ks <- js]) -- | Do a batch of jobs. @@ -1288,11 +1293,7 @@ _ -> 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 + fromMaybe Locked <$> attempting c.outage (log' c) "cache an xpub" (cacheRefresh c x ts) -- | 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 diff --git a/src/Haskoin/Store/Fleet.hs b/src/Haskoin/Store/Fleet.hs --- a/src/Haskoin/Store/Fleet.hs +++ b/src/Haskoin/Store/Fleet.hs @@ -47,7 +47,10 @@ -- -- * __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. +-- set, so two stores that try at once do the same thing once. The store +-- that moves it also says what the blocks in between did to the shared +-- mempool; what happens when it cannot is with the mempool, in +-- "Haskoin.Store.Fleet.Redis". -- -- * __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 diff --git a/src/Haskoin/Store/Fleet/Member.hs b/src/Haskoin/Store/Fleet/Member.hs --- a/src/Haskoin/Store/Fleet/Member.hs +++ b/src/Haskoin/Store/Fleet/Member.hs @@ -25,7 +25,10 @@ -- ('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. +-- across a reorganisation which transactions come back. Across more +-- blocks than a store goes through ('farthest'), it moves the tip and +-- starts the pool again ('wayBetween'), and every member that sees that +-- the pool was emptied offers its whole mempool again ('noteRestarts'). -- -- * __It offers its mempool to the shared pool__ ('offerMempool'), each -- transaction with whether its inputs are unspent in the store's view at @@ -84,6 +87,9 @@ moveTip, Between (..), blocksBetween, + wayBetween, + Way (..), + farthest, changeBetween, offerMempool, expirePool, @@ -105,7 +111,7 @@ 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.Maybe (catMaybes, fromMaybe, isJust, isNothing, mapMaybe) import Data.Serialize (Serialize, decode, encode) import Data.Text (Text) import Data.Text qualified as T @@ -156,6 +162,7 @@ import Haskoin.Store.Fleet qualified as F import Haskoin.Store.Fleet.Redis import Haskoin.Store.Fleet.XPub +import Haskoin.Store.Outage (Outage, attempt, newOutage) import System.Metrics.StatsD ( StatCounter, StatGauge, @@ -307,13 +314,19 @@ -- | the fleet tip at which the cache was found at another block, at -- the last turn lagging :: !(TVar (Maybe ByteString)), + -- | how many times the pool had been emptied at this store's last + -- turn ('noteRestarts') + restarts :: !(TVar (Maybe Integer)), -- | 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)) + gone :: !(TVar (HashSet TxHash)), + -- | whether the last thing that the member tried with Redis failed, + -- so that an outage is logged once, by whichever loop meets it + outage :: !Outage } -- | A member with no views yet, on a connection to the Redis of the fleet. @@ -331,8 +344,10 @@ healthy <- newTVarIO True wanted <- newTVarIO HashMap.empty lagging <- newTVarIO Nothing + restarts <- newTVarIO Nothing metrics <- mapM newCacheMetrics config.stats gone <- newTVarIO HashSet.empty + outage <- newOutage return Member {keys = fleetKeys config.prefix 32, ..} -- | Take a view of the database for its best block. The block store calls @@ -389,6 +404,7 @@ -- 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)) + noteRestarts m prune m syncCache m unless moved (expirePool m) @@ -396,17 +412,33 @@ where decoded = either (const Nothing) Just . decode +-- | Forget what this store offered to the pool, if the pool was emptied +-- since the store's last turn, by this store or by another +-- ('fleetRestarts'): the next offer is then of the whole mempool. Without +-- this a store went on taking what it had offered to be in the pool, and +-- the pool of a fleet that started again had only what came in afterwards. +noteRestarts :: Member -> IO () +noteRestarts m = do + now <- fleetRestarts m.redis m.keys + atomically $ do + before <- readTVar m.restarts + writeTVar m.restarts (Just now) + when (maybe False (/= now) before) $ do + writeTVar m.offered HashSet.empty + writeTVar m.waiting HashMap.empty + writeTVar m.changed True + -- | 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 +-- health checks pass. A turn that fails, as when Redis is away, is tried +-- again at the next, and logged as an outage is ('attempt'). +memberLoop :: Member -> IO () -> IO a +memberLoop m nextBlock = go where go = do void (timeout 2000000 nextBlock) well <- readTVarIO m.healthy - when well (handleAny (complain . show) (memberTick m)) + when well (void (attempt m.outage m.config.note "take a turn in the fleet" (memberTick m))) go -- | Hear what happens to the fleet, for as long as the store runs: each @@ -418,25 +450,23 @@ -- 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 +-- does. When Redis cannot be read, that is logged as an outage is +-- ('attempt'), and listening goes on a second later from the last event +-- heard, so nothing is left out unless Redis dropped it meanwhile. +memberEvents :: Member -> Bool -> (FleetEvent -> IO ()) -> IO a +memberEvents m whole tell = newIORef (if whole then Just "0-0" else Nothing) >>= go 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 + go at = do + heard <- attempt m.outage m.config.note "read the events of the fleet" (listen at) + unless heard (void (timeout 1000000 (atomically retrySTM) :: IO (Maybe ()))) + go at + -- what there is after the place, waiting a second for it + listen at = do + from <- readIORef at >>= maybe (fleetEventsEnd m.redis m.keys) return + writeIORef at (Just from) 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 + writeIORef at (Just (foldl (\_ (place, _) -> place) from events)) -- | Report the blocks of the main chain that the store has views of, newest -- first. @@ -447,13 +477,16 @@ 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 [])) + unless taken . m.config.note LevelDebug $ + "Report not taken: this store has no view of the fleet tip, and another store is live" 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. +-- emptied: Redis allows that to a store that is alone, and to any store +-- when the way is too long for all of them (v'TooFar'). moveTip :: Member -> IO Bool moveTip m = do seen <- fleetTip m.redis m.keys @@ -469,14 +502,44 @@ 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 + way <- case (traverse decode seen, decode target) of + (Right from, Right to) -> wayBetween m.db from to + _ -> return NoWay + let between = case way of + Way b -> Just b + _ -> Nothing + path = maybe [] (map encode . (.path)) between + moved <- case way of + TooFar -> do + m.config.note LevelWarn $ + "The fleet tip is more than " + <> shown farthest + <> " blocks from " + <> blockName target + <> ": starting the shared mempool again there" + fleetRestart m.redis m.keys 32 Nothing seen target + _ -> fleetAdvance m.redis m.keys 32 Nothing seen target ((.pool) <$> between) path + m.config.note LevelDebug . mconcat $ + [ "Fleet tip from ", + maybe "none" blockName seen, + " to ", + blockName target, + case moved of + MovedTo _ -> ": moved" + Stays -> ": stays" + Raced -> ": not moved, another store did it first or has to", + case way of + Way _ -> "" + NoWay -> " (this store does not know the way)" + TooFar -> " (the way is too long)" + ] + case moved of MovedTo _ -> advanceCache m seen target between >> return True _ -> return False - _ -> return False + agreed -> do + when (isNothing agreed) . m.config.note LevelDebug $ + "The live stores have no block in common: " <> shown (Map.size reports) <> " reports" + 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 @@ -523,38 +586,60 @@ -- 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 +blocksBetween db from to = + wayBetween db from to <&> \case + Way between -> Just between + _ -> Nothing + +-- | What a store can say of the way between two tips. +data Way + = -- | what the blocks between them did + Way !Between + | -- | nothing: it does not have one of the tips, or the second is not + -- on its main chain. Another store may know. + NoWay + | -- | it has both, and the way is longer than 'farthest' blocks on one + -- side of the fork. That is so for every store. + TooFar + +-- | 'blocksBetween', telling a way that is too long from one that the +-- store does not know. The fleet treats them differently: a tip that no +-- store will ever say the way from has to be left behind +-- ('fleetRestart'), and one that another store may know has to wait. +wayBetween :: DatabaseReader -> Maybe BlockHash -> BlockHash -> IO Way +wayBetween 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 :: Int -> BlockHash -> IO (Either Way ([BlockData], BlockData)) back n h - | n > farthest = return Nothing + | n > farthest = return (Left TooFar) | otherwise = Q.getBlock r h >>= \case - Nothing -> return Nothing + Nothing -> return (Left NoWay) Just bd - | bd.main -> return (Just ([], bd)) + | bd.main -> return (Right ([], 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 :: Int -> BlockData -> BlockData -> IO (Either Way [BlockData]) down n fork bd - | n > farthest = return Nothing - | bd.height <= fork.height = return (if bd.header == fork.header then Just [] else Nothing) + | n > farthest = return (Left TooFar) + | bd.height <= fork.height = return (if bd.header == fork.header then Right [] else Left NoWay) | otherwise = Q.getBlock r bd.header.prev >>= \case - Nothing -> return Nothing + Nothing -> return (Left NoWay) 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) + Nothing -> return (maybe (Left NoWay) (Right . ([],)) target) case (target, left) of - (Just bd, Just (abandoned, fork)) + (_, Left none) -> return none + (Just bd, Right (abandoned, fork)) | bd.main -> down 0 fork bd >>= \case - Nothing -> return Nothing - Just added -> do + Left none -> return none + Right added -> do old <- concat <$> mapM (bodies view) (reverse abandoned) new <- concat <$> mapM (confirmedBy r) (reverse added) let pool = @@ -565,8 +650,8 @@ 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 + return (Way Between {pool, added = new, reorganised = not (null abandoned), path}) + _ -> return NoWay 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 @@ -888,8 +973,8 @@ -- 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 +memberCacheLoop :: Member -> IO a +memberCacheLoop m = go where go = do spec <- atomically $ do @@ -897,7 +982,7 @@ case HashMap.toList w of [] -> retrySTM (k, x) : _ -> x <$ writeTVar m.wanted (HashMap.delete k w) - handleAny (complain . show) (build spec) + void (attempt m.outage m.config.note "cache an xpub for the fleet" (build spec)) go build spec = readTVarIO m.tip >>= \case diff --git a/src/Haskoin/Store/Fleet/Redis.hs b/src/Haskoin/Store/Fleet/Redis.hs --- a/src/Haskoin/Store/Fleet/Redis.hs +++ b/src/Haskoin/Store/Fleet/Redis.hs @@ -72,6 +72,8 @@ poolOffer, poolWithdraw, fleetAdvance, + fleetRestart, + fleetRestarts, FleetEvent (..), fleetEventsEnd, fleetEventsAfter, @@ -85,6 +87,7 @@ import Data.ByteString qualified as B import Data.ByteString.Char8 qualified as C import Data.FileEmbed (embedFile, makeRelativeToProject) +import Data.Maybe (fromMaybe) import Data.Word (Word64) import Database.Redis (Connection, Redis, Reply) import Database.Redis qualified as R @@ -256,11 +259,11 @@ -- 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. +-- tip, 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. With another store live the answer is 'Raced', and the tip waits +-- for a store that knows the way. When the way is known and too long, +-- see 'fleetRestart'. -- -- 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'): @@ -275,7 +278,45 @@ Maybe PoolChange -> [ByteString] -> IO Moved -fleetAdvance conn keys tsize clock seen target known path = +fleetAdvance conn keys tsize clock seen target known = + advance conn keys tsize clock seen target (maybe "1" (const "0") known) (fromMaybe (PoolChange [] [] [] []) known) + +-- | Move the tip to a block and empty the pool, for a store that has both +-- the tip and the block and finds the way between them longer than it +-- goes through. +-- +-- Unlike a store that does not have the old tip, it may do this with +-- other stores live. The length of the way is the same for all of them, so +-- none would ever say what the blocks did, and the tip would stay where it +-- is for good: a fleet whose stores came back together after half a day +-- away answered nothing from then on. Emptying the pool costs the stores +-- an offer of their mempools, which they make when they see that the +-- count of 'fleetRestarts' went up. +fleetRestart :: Connection -> FleetKeys -> Int -> Maybe Time -> Maybe ByteString -> ByteString -> IO Moved +fleetRestart conn keys tsize clock seen target = + advance conn keys tsize clock seen target "2" (PoolChange [] [] [] []) [] + +-- | How many times the pool was emptied to move the tip. A store that sees +-- another number than at its last turn offers all of its mempool again: +-- what it offered before is not in the pool any more. +fleetRestarts :: Connection -> FleetKeys -> IO Integer +fleetRestarts conn keys = + maybe 0 (maybe 0 fst . C.readInteger) <$> run conn (R.get (keys.prefix <> "fleet:restarts")) + +-- | The advance of the pool script, with its way of treating the pool: "0" +-- to change it, "1" and "2" to empty it ('fleetAdvance', 'fleetRestart'). +advance :: + Connection -> + FleetKeys -> + Int -> + Maybe Time -> + Maybe ByteString -> + ByteString -> + ByteString -> + PoolChange -> + [ByteString] -> + IO Moved +advance conn keys tsize clock seen target how change path = run conn (R.eval poolScript [] args) >>= \case ["moved"] -> return (MovedTo target) ["stays"] -> return Stays @@ -283,14 +324,11 @@ 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] + ["advance", keys.prefix, num tsize, maybe "" id seen, target, maybe "" num clock, num keys.size, how] <> [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, diff --git a/src/Haskoin/Store/Fleet/lua/pool.lua b/src/Haskoin/Store/Fleet/lua/pool.lua --- a/src/Haskoin/Store/Fleet/lua/pool.lua +++ b/src/Haskoin/Store/Fleet/lua/pool.lua @@ -30,10 +30,17 @@ -- 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. +-- or ''. Returns {'moved'}, {'stays'} or {'raced'}. -- +-- The pool is emptied instead of changed in two cases. With '1' the store +-- cannot say what the blocks between the two tips did, because it does +-- not have the old tip: only when no other store is live, and {'raced'} +-- otherwise, since another store may know. With '2' the store has both +-- tips and the way between them is longer than a store goes through: that +-- is so for every store, so any of them may, or the tip would never move +-- again. Each time the pool is emptied a counter goes up, next to the +-- tip, which tells the stores to offer their mempools again. +-- -- 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 @@ -66,6 +73,7 @@ local key = { tip = prefix .. 'fleet:tip', moves = prefix .. 'fleet:moves', + restarts = prefix .. 'fleet:restarts', events = prefix .. 'fleet:events', lease = prefix .. 'fleet:lease', recent = prefix .. 'fleet:recent', @@ -407,12 +415,13 @@ 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 +-- a store that does not know the way from the old tip starts the pool +-- again: if it is alone, or if the way is too long for any store +if ARGV[8] == '1' or ARGV[8] == '2' then + if ARGV[8] == '1' and #live ~= 1 then return {'raced'} end + redis.call('INCR', key.restarts) for _, k in ipairs(redis.call('KEYS', prefix .. 'pool:*')) do redis.call('DEL', k) end diff --git a/src/Haskoin/Store/Logic/Layered.hs b/src/Haskoin/Store/Logic/Layered.hs --- a/src/Haskoin/Store/Logic/Layered.hs +++ b/src/Haskoin/Store/Logic/Layered.hs @@ -122,6 +122,11 @@ ------------------------------------------------------------------------------- -- | Log a message with the logger of the writer. +-- What a peer sends and the store refuses (an orphan, a double spend, a +-- transaction without funds) is logged for debugging: it is the ordinary +-- traffic of a network, and nothing is wrong with the store. An error is +-- kept for what should not happen whatever peers do: a block that does not +-- fit the database. logDebug, logError :: Writer -> Text -> IO () logDebug wr = logAt LevelDebug (writerLogger wr) logError wr = logAt LevelError (writerLogger wr) @@ -545,7 +550,7 @@ spendable wr p >>= \case Just u -> return u Nothing -> do - logError wr $ "Attempted to import a tx missing UTXO: " <> txHashToHex (txHash tx) + logDebug 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 @@ -646,7 +651,7 @@ deleteSingleTx wr th = getMempoolTx wr th >>= \case Nothing -> do - logError wr $ "Already deleted: " <> txHashToHex th + logDebug wr $ "Already deleted: " <> txHashToHex th throwIO TxNotFound Just td -> do spenders <- getMempoolSpenders wr th (length td.tx.outputs) @@ -663,17 +668,17 @@ 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) + logDebug 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) + logDebug wr $ "Orphan: " <> txHashToHex (txHash tx) throwIO Orphan when (isCoinbaseTx tx) $ do - logError wr $ "Coinbase cannot be imported into mempool: " <> txHashToHex (txHash tx) + logDebug 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) + logDebug wr $ "Insufficient funds for tx: " <> txHashToHex (txHash tx) throwIO InsufficientFunds where prev_output op @@ -711,13 +716,13 @@ return Nothing Just td | memonly && confirmed td.block -> do - logError wr $ "Transaction already confirmed: " <> txHashToHex th + logDebug 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 + logDebug wr $ "Double-spending transaction: " <> txHashToHex th throwIO DoubleSpend | otherwise -> return $ Just td go txm pdg = do 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 @@ -291,10 +291,10 @@ -- 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 = +withStoreFleet _ pub (Just member) action = withSubscription pub $ \sub -> - withAsync (memberLoop member (nextBlock sub) complain) $ \a -> - withAsync (memberCacheLoop member cacheComplain) $ \b -> link a >> link b >> action + withAsync (memberLoop member (nextBlock sub)) $ \a -> + withAsync (memberCacheLoop member) $ \b -> link a >> link b >> action where -- until the next block, telling the member what the store deletes nextBlock sub = @@ -302,8 +302,6 @@ 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 @@ -315,9 +313,9 @@ (Publisher StoreEvent -> IO a) -> IO a withFleetEvents _ pub Nothing action = action pub -withFleetEvents cfg _ (Just member) action = +withFleetEvents _ _ (Just member) action = withPublisher $ \shared -> - withAsync (memberEvents member False (tell shared) complain) $ \a -> link a >> action shared + withAsync (memberEvents member False (tell shared)) $ \a -> link a >> action shared where tell shared event = forM_ (told event) (`publish` shared) told = \case @@ -326,7 +324,6 @@ 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 :: diff --git a/src/Haskoin/Store/Outage.hs b/src/Haskoin/Store/Outage.hs new file mode 100644 --- /dev/null +++ b/src/Haskoin/Store/Outage.hs @@ -0,0 +1,81 @@ +-- | +-- Module : Haskoin.Store.Outage +-- Copyright : (c) Haskoin Developers +-- License : MIT +-- Maintainer : jprupp@protonmail.ch +-- Stability : experimental +-- Portability : POSIX +-- +-- Saying once that something the store depends on stopped working, and +-- once that it works again. +-- +-- The store goes on without Redis: it answers from its database and tries +-- again. Several loops try every second or two, and each used to log every +-- failure, so an outage of an hour was thousands of lines that said the +-- same, and nothing said when it was over. Here a failure is logged as a +-- warning when it is the first after things worked, for debugging while +-- they keep failing, and the first success after that is logged too. +-- +-- The loops that depend on the same thing share one t'Outage', so that the +-- outage is told once and not once by each. If one of them fails for a +-- reason of its own while the others work, the log alternates between the +-- two lines, which is as loud as such a fault should be. +-- +-- Logging at most one line a minute was the alternative. It needs no +-- signal of success, but it never says that the outage ended, and it +-- hides a second, different failure that comes within the minute. +module Haskoin.Store.Outage + ( Outage, + newOutage, + attempt, + attempting, + ) +where + +import Control.Monad (when) +import Data.Maybe (isJust) +import Data.String.Conversions (cs) +import Data.Text (Text) +import Haskoin.Node (LogLevel (..)) +import UnliftIO (TVar, atomically, newTVarIO, swapTVar, tryAny) + +-- | Whether the last attempt at something failed. +newtype Outage = Outage (TVar Bool) + +-- | Nothing has failed yet. +newOutage :: IO Outage +newOutage = Outage <$> newTVarIO False + +-- | Do something that may fail because a service is away, and say whether +-- it worked. A failure is logged with a function, as a warning if the +-- attempt before it worked and for debugging otherwise; a success after a +-- failure is logged as information. The text says what is attempted, to +-- follow "Could not" and "Can again": @"take a turn in the fleet"@. +-- +-- Exceptions that are thrown to the thread from outside, as when it is +-- stopped, are not caught. +attempt :: Outage -> (LogLevel -> Text -> IO ()) -> Text -> IO () -> IO Bool +attempt outage note doing action = isJust <$> attempting outage note doing action + +-- | 'attempt' for an action with a result, which is 'Nothing' when the +-- action failed. +attempting :: Outage -> (LogLevel -> Text -> IO ()) -> Text -> IO a -> IO (Maybe a) +attempting (Outage down) note doing action = + tryAny action >>= \case + Right x -> do + was <- atomically (swapTVar down False) + when was (note LevelInfo ("Can " <> doing <> " again")) + return (Just x) + Left e -> do + was <- atomically (swapTVar down True) + if was + then note LevelDebug ("Could not " <> doing <> ": " <> cs (show e)) + else + note LevelWarn . mconcat $ + [ "Could not ", + doing, + ": ", + cs (show e), + ". Going on without; this is said again only for debugging, until it works" + ] + return Nothing 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 @@ -74,6 +74,10 @@ -- * Request parsing decodeTxBody, acceptsBinary, + + -- * Logging + logIt, + ailments, ) where @@ -178,6 +182,8 @@ getPeers, logDebug, logError, + logInfo, + logWarn, sendMessage, withSource, ) @@ -239,7 +245,6 @@ status503, statusIsClientError, statusIsServerError, - statusIsSuccessful, ) import Network.Socket (Socket) import Network.Wai @@ -283,6 +288,7 @@ import Network.Wreq qualified as Wreq import Network.Wreq.Session as Wreq (Session) import Network.Wreq.Session qualified as Wreq.Session +import Numeric (showFFloat) import Numeric.Natural (Natural) import System.Metrics.StatsD import Text.Read (readMaybe) @@ -294,6 +300,7 @@ bracket_, catch, catchAny, + checkSTM, fromException, handleAny, link, @@ -303,7 +310,9 @@ race_, readIORef, readTQueue, + readTVar, readTVarIO, + registerDelay, stateTVar, throwIO, timeout, @@ -333,13 +342,16 @@ -- unhealthy txTimeout :: !Word64, -- | seconds without a new block before the store is reported unhealthy - blockTimeout :: !Word64 + blockTimeout :: !Word64, + -- | seconds that a request may take before the log has a warning + -- about it ('logIt') + slowRequest :: !Word32 } 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. +-- default, xpub gaps of 32 and 20, transaction timeout of 30 minutes, +-- block timeout of four hours, and a warning for requests of five seconds. instance Default WebLimits where def = WebLimits @@ -350,7 +362,8 @@ xpubGap = 32, xpubGapInit = 20, txTimeout = 3600 `div` 2, - blockTimeout = 4 * 3600 + blockTimeout = 4 * 3600, + slowRequest = 5 } -- | Configuration of the web server. @@ -387,8 +400,11 @@ noXPub :: !Bool, -- | disable the Blockchain.info compatible endpoints noBlockchainInfo :: !Bool, - -- | seconds between health checks + -- | seconds between health checks; there is one at each new block + -- too healthCheckInterval :: !Int, + -- | log every request, at the level of information ('logIt') + accessLog :: !Bool, -- | a certificate and its private key, in files in PEM format, to -- serve HTTPS instead of HTTP; 'Nothing' for HTTP, which is the -- default @@ -644,7 +660,14 @@ ticker <- newTVarIO HashMap.empty metrics <- mapM createMetrics config.stats session <- Wreq.Session.newAPISession - health <- runHealthCheck >>= newTVarIO + first <- runHealthCheck + health <- newTVarIO first + -- A member of a fleet takes no turn before its store is known to be + -- well. A member is made ready to take turns, since a store without a + -- web server has nothing else to say when; with one, a store that had + -- just started took a turn before its first check, reported the blocks + -- that it had then, and with nobody else there moved the fleet to them. + forM_ config.store.fleet $ \member -> atomically (writeTVar member.healthy (isOK first)) cacheUp <- cacheCheck >>= newTVarIO eventLog <- newEventLog let db = config.store.db @@ -712,11 +735,18 @@ notFound req (Unknown ks) = errorResponse st req . UserError $ "Unknown parameter: " <> T.unpack (T.intercalate ", " ks) + saidWell <- newIORef Nothing + saidRedis <- newIORef True + pinged <- newIORef 0 + -- set when the store has a new best block, for the health check to run + -- at once + newBlock <- newTVarIO False withAsync (priceUpdater session ticker) $ \_a1 -> - withAsync (healthCheckLoop health cacheUp) $ \_a2 -> + withAsync (healthCheckLoop health cacheUp saidWell saidRedis pinged newBlock) $ \_a2 -> withAsync (feedEvents st) $ \a3 -> link a3 >> do - serve . webSocketEvents st . logIt config.logger . anyOrigin . preflight . autohead . compressed $ app + let logged = logIt config.logger config.accessLog config.limits.slowRequest + serve . webSocketEvents st . logged . anyOrigin . preflight . autohead . compressed $ app where priceUpdater session = unless config.noBlockchainInfo @@ -731,14 +761,68 @@ (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 + -- The check is run every second by default, and at once when the + -- store has a new best block, which is when its answer changes most: + -- /health answers from the last result, and a load balancer or a + -- fleet that acts on a result of half a minute ago sends requests to + -- a server that fell behind. A check reads a handful of keys, so it + -- costs little to run often; but a store that is catching up imports + -- thousands of small blocks a second, and a check for each would be + -- work for nothing, so there is a tenth of a second between two. + healthCheckLoop v up saidWell saidRedis pinged newBlock = + bracket (subscribe config.store.pub (heard newBlock)) (unsubscribe config.store.pub) $ \_ -> + loopForever $ do + threadDelay 100000 + due <- registerDelay (config.healthCheckInterval * 1000 * 1000) + atomically $ do + block <- readTVar newBlock + time <- readTVar due + checkSTM (block || time) + writeTVar newBlock False + h <- runHealthCheck + atomically (writeTVar v h) + tellHealth saidWell 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)) + -- Redis is asked less often, every five seconds: it is the one + -- part of the check that leaves the program, and waits up to + -- two seconds for a Redis that is away. Requests find out by + -- themselves that Redis is away; this is how the store finds + -- out that it is back. + now <- getPOSIXTime + last' <- readIORef pinged + when (now - last' >= 5) $ do + writeIORef pinged now + redis <- cacheCheck + atomically (writeTVar up redis) + tellRedis saidRedis redis + heard newBlock = \case + StoreBestBlock _ -> writeTVar newBlock True + _ -> return () + -- A change of health is logged, and nothing while it stays as it was: + -- what /health answers is otherwise only known to whoever asks it. A + -- store is not healthy while it syncs, which is no cause for alarm, + -- so only a store that was healthy gets a warning. + health' = withSource "Health" config.logger + tellHealth said h = do + before <- readIORef said + writeIORef said (Just (isOK h)) + case (before, isOK h) of + (Just True, False) -> logWarn health' ("No longer healthy: " <> ailments h) + (Nothing, False) -> logInfo health' ("Not healthy yet: " <> ailments h) + (Just False, True) -> logInfo health' "Healthy again" + (Nothing, True) -> logInfo health' "Healthy" + _ -> return () + -- the same for the Redis that a store with a cache answers through; + -- /health says 203 without it + tellRedis said redis = do + before <- readIORef said + writeIORef said redis + case (before, redis) of + (True, False) -> logWarn health' "Redis does not answer: answering from the database" + (False, True) -> logInfo health' "Redis answers again" + _ -> return () -- 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. @@ -839,7 +923,7 @@ return $ r ^. Wreq.responseBody where err _ = do - logError logger "Could not get historic prices" + logWarn logger "Could not get historic prices" return [] body = toJSON times base = @@ -857,7 +941,7 @@ 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) + let err e = logWarn logger $ "Could not get prices: " <> cs (show e) handleAny err $ do r <- Wreq.asJSON =<< Wreq.Session.get session u atomically . writeTVar v $ r ^. Wreq.responseBody @@ -1722,7 +1806,7 @@ -- 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 + Just member -> memberEvents member True (mapM_ happened . fleet) Nothing -> do queue <- newTQueueIO let listen = mapM_ (writeTQueue queue) . local @@ -1748,7 +1832,6 @@ -- 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 -- @@ -3503,16 +3586,63 @@ 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 = +-- | Middleware that logs every request with its response status. Only an +-- error of the server is logged as one: a request that the server could +-- not answer although nothing was wrong with it (500). +-- +-- A request that the client got wrong (400, 404) is the client's error, +-- and a public server gets them all day. A 503 is the server saying that +-- it is not ready, which its health check and its fleet already report. +-- Both are logged for debugging, as successes are; logged as errors they +-- hid the ones that are. +-- +-- A request that took a number of seconds or more to answer gets a +-- warning, with how long it took (0 for never). That is the one thing +-- about a single request that says something of the server: a query that +-- reads far more than it should, or a database that has become slow. The +-- time is that of making the response, not of sending it, so a client on +-- a slow line is not the server's slow request; and the stream of events, +-- whose response never ends, is left out. +-- +-- With the access log on, every request is logged as information instead +-- of for debugging, with the address of the client and the time it took. +-- It is off by default: a public server has a proxy in front that keeps +-- such a log, and knows the address of the client, where the server sees +-- that of the proxy unless the proxy passes it on in @X-Forwarded-For@. +-- It is for a server that is run without one. +logIt :: Logger -> Bool -> Word32 -> Middleware +logIt logger access slow app req respond = do + start <- getPOSIXTime app req $ \res -> do + took <- subtract start <$> getPOSIXTime let s = responseStatus res msg = fmtReq req <> ": " <> fmtStatus s - if statusIsSuccessful s - then logDebug logger msg - else logError logger msg + seconds = cs (showFFloat (Just 1) (realToFrac took :: Double) "") + millis = cs (showFFloat (Just 1) (realToFrac took * 1000 :: Double) "") + client = case lookup "X-Forwarded-For" (requestHeaders req) of + Just given -> T.strip (T.takeWhile (/= ',') (T.decodeUtf8Lenient given)) + Nothing -> cs (show (remoteHost req)) + if + | statusIsServerError s && s /= status503 -> logError logger msg + | access -> logInfo logger (client <> " " <> msg <> ", " <> millis <> " ms") + | otherwise -> logDebug logger msg + when (slow > 0 && took >= fromIntegral slow && pathInfo req /= ["events"]) $ + logWarn logger ("Slow request, " <> seconds <> " seconds: " <> msg) respond res + +-- | What is wrong with a store whose health check fails, for its log. +ailments :: HealthCheck -> Text +ailments h = + T.intercalate ", " . concat $ + [ [shown (h.blocks.headers - h.blocks.blocks) <> " blocks behind the headers" | not (isOK h.blocks)], + [shown h.lastBlock.age <> " seconds since the last block" | not (isOK h.lastBlock)], + [shown h.lastTx.age <> " seconds since the last transaction" | not (isOK h.lastTx)], + [shown h.pendingTxs.count <> " transactions waiting to be imported" | not (isOK h.pendingTxs)], + [shown h.peers.count <> " peers" | not (isOK h.peers)] + ] + where + shown :: (Show a) => a -> Text + shown = cs . show -- | Describe a request for logs. fmtReq :: Request -> Text diff --git a/swagger.yaml b/swagger.yaml --- a/swagger.yaml +++ b/swagger.yaml @@ -12,7 +12,7 @@ - url: 'https://api.haskoin.com/btctest4/' info: - version: &version 1.9.0 + version: &version 1.9.1 title: Haskoin contact: name: JP Rupp diff --git a/test/Haskoin/Store/Fleet/MemberSpec.hs b/test/Haskoin/Store/Fleet/MemberSpec.hs --- a/test/Haskoin/Store/Fleet/MemberSpec.hs +++ b/test/Haskoin/Store/Fleet/MemberSpec.hs @@ -1,9 +1,10 @@ module Haskoin.Store.Fleet.MemberSpec (spec) where -import Control.Monad (foldM_, void, when) +import Control.Monad (foldM, foldM_, forM_, void, when) import Data.Default (def) import Data.Either (isRight) import Data.IORef (modifyIORef', newIORef, readIORef) +import Data.Maybe (isJust) import Data.Serialize (encode) import Data.Text qualified as T import Data.Word (Word16) @@ -15,7 +16,7 @@ import Haskoin.Store.Database.Query.Pooled (pooledRead) import Haskoin.Store.Database.Views (closeViews) import Haskoin.Store.Fleet.Member -import Haskoin.Store.Fleet.Redis (FleetKeys (..), poolWithdraw) +import Haskoin.Store.Fleet.Redis (FleetKeys (..), fleetRestarts, poolWithdraw) import Haskoin.Store.Fleet.RedisSpec (withRedis) import Haskoin.Store.Fleet.XPub import Haskoin.Store.Histories @@ -240,6 +241,94 @@ [() | (level, _) <- logged, level /= LevelInfo, level /= LevelDebug] `shouldBe` [] emptied `shouldSatisfy` all ("Emptied the xpub cache at block " `T.isPrefixOf`) readIORef hits >>= (`shouldSatisfy` (> 10)) + it "leaves behind a tip that is too far for every store, and fills the pool again" $ \(conn, fresh) -> + -- Two stores of one fleet, both live and both with a view of the + -- tip, take no turn while their chain grows by more blocks than a + -- store goes through to say what they did to the pool: as stores do + -- that are behind, whose health checks fail until they have caught + -- up. When they take their turns again, the tip is where it was. + -- + -- No store will ever say the way from there, and neither is alone, + -- which is what Redis asked of a store that empties the pool: the + -- tip stayed there for good, and every request was answered that + -- the store was behind its fleet. The integration tests met this + -- when the health check began to run at every block, which made + -- stores stop taking turns sooner than they used to. + -- + -- Now the first to take a turn moves the tip to their best block + -- and empties the pool, and both offer their mempools again: what + -- they answer afterwards is what the store answers by itself. + withSystemTempDirectory "haskoin-store-member-" $ \dir -> + openLayered btcRegTest ctx dir $ \db -> withShadow btcRegTest ctx $ \shadow -> do + keys <- fresh + said <- newIORef [] + let config name = + MemberConfig + { prefix = keys.prefix, + name, + lease = 60000, + depth = 6, + expiry = 0, + cacheMax = 0, + cacheMinAddrs = 0, + cacheMinTxs = 0, + stats = Nothing, + note = \level line -> modifyIORef' said ((level, line) :) + } + best = Q.getBestBlock db >>= maybe (fail "no best block") return + a <- newMember (config "a") conn db + b <- newMember (config "b") conn db + let both f = f a >> f b + done hist op = do + void (apply mixedRules shadow op) + out <- apply layeredRules db op + both (`memberForget` out.removed) + return (record db hist op out) + pay hist seed = + plan shadow hist seed >>= \case + (hist', Nothing) -> return hist' + (hist', Just op) -> done hist' op + mine hist = do + hist' <- blockOn db [] >>= done hist + -- as the block store does after each block + best >>= \h -> both (`noteBest` h) + return hist' + same hist = do + own <- layered db (ask hist) + forM_ [a, b] $ \m -> + answering m (\r pool -> ask hist (pooledRead r pool)) >>= \case + Answered shared -> shared `shouldBe` own + Alone -> expectationFailure "the fleet has no tip" + Behind -> expectationFailure "a store has no view of the fleet tip" + hist0 <- start layeredRules db + best >>= \h -> both (`noteBest` h) + both memberTick + -- payments that both stores have, and that the pool takes + hist1 <- foldM pay hist0 (onlyPayments [100, 2000, 30000, 4000, 500, 60000]) + both memberTick + old <- memberTip a + old `shouldSatisfy` isJust + same hist1 + Q.getMempool db >>= (`shouldSatisfy` (not . null)) + -- more blocks than a store goes through, and no turn taken + hist2 <- foldM (\hist _ -> mine hist) hist1 [1 .. farthest + 5] + restarts <- fleetRestarts conn keys + memberTip a `shouldReturn` old + both memberTick + new <- encode <$> best + memberTip a `shouldReturn` Just new + fleetRestarts conn keys `shouldReturn` restarts + 1 + -- the pool was emptied, and has again what the stores have + both memberTick + same hist2 + Q.getMempool db >>= (`shouldSatisfy` (not . null)) + closeViews a.views + closeViews b.views + -- said once, by the store that did it, as a warning + logged <- readIORef said + [line | (LevelWarn, line) <- logged] `shouldSatisfy` \case + [line] -> "starting the shared mempool again" `T.isInfixOf` line + _ -> False -- | A history that a run of the tests found: a block is mined, reverted and -- mined again while the cache is not brought along, so that the fleet tip diff --git a/test/Haskoin/Store/Fleet/RedisSpec.hs b/test/Haskoin/Store/Fleet/RedisSpec.hs --- a/test/Haskoin/Store/Fleet/RedisSpec.hs +++ b/test/Haskoin/Store/Fleet/RedisSpec.hs @@ -128,6 +128,34 @@ poolSpends conn keys `shouldReturn` [] (Redis.runRedis conn (Redis.keys (keys.prefix <> "pool:*")) >>= either (fail . show) return) `shouldReturn` [] + it "empties the pool for any store when the way is too long, and counts it" $ \(conn, fresh) -> do + keys <- fresh + fleetReport conn keys (Just 0) 10 "a" [block 1] [] `shouldReturn` True + fleetAdvance conn keys 4 (Just 0) Nothing (block 1) Nothing [] `shouldReturn` MovedTo (block 1) + poolOffer conn keys 4 (Just (block 1)) (txOf 7 [out 0 0]) [True] [] `shouldReturn` Taken + before <- fleetRestarts conn keys + -- two stores that both have a view of the tip, so both are live, + -- at a block that neither will say the way to + fleetReport conn keys (Just 0) 10 "a" [block 2] [block 2, block 1] `shouldReturn` True + fleetReport conn keys (Just 0) 10 "b" [block 2] [block 2, block 1] `shouldReturn` True + -- a store that does not know the way waits for one that does + fleetAdvance conn keys 4 (Just 0) (Just (block 1)) (block 2) Nothing [] `shouldReturn` Raced + fleetRestarts conn keys `shouldReturn` before + fleetTip conn keys `shouldReturn` Just (block 1) + -- one that knows it and finds it too long does not, or the tip + -- would never move again + fleetRestart conn keys 4 (Just 0) (Just (block 1)) (block 2) `shouldReturn` MovedTo (block 2) + fleetTip conn keys `shouldReturn` Just (block 2) + poolSpends conn keys `shouldReturn` [] + (Redis.runRedis conn (Redis.keys (keys.prefix <> "pool:*")) >>= either (fail . show) return) + `shouldReturn` [] + -- which the stores hear of, to offer their mempools again + fleetRestarts conn keys `shouldReturn` before + 1 + -- still only to the block that the live stores agree on, and only + -- from the tip that the store saw + fleetRestart conn keys 4 (Just 0) (Just (block 2)) (block 3) `shouldReturn` Raced + fleetRestart conn keys 4 (Just 0) (Just (block 1)) (block 2) `shouldReturn` Raced + fleetRestarts conn keys `shouldReturn` before + 1 it "reads the pool by the page, as it is at the tip that is asked for" $ \(conn, fresh) -> do keys <- fresh fleetReport conn keys (Just 0) 10 "a" [block 1] [] `shouldReturn` True diff --git a/test/Haskoin/Store/IntegrationSpec.hs b/test/Haskoin/Store/IntegrationSpec.hs --- a/test/Haskoin/Store/IntegrationSpec.hs +++ b/test/Haskoin/Store/IntegrationSpec.hs @@ -57,6 +57,7 @@ import Data.String.Conversions (cs) import Data.Text (Text) import Data.Text qualified as T +import Data.Time.Clock.POSIX (getPOSIXTime) import Data.Word (Word32, Word64) import Database.Redis qualified as Redis import Haskoin @@ -138,6 +139,7 @@ import Network.Wreq.Types (FormParam ((:=))) import System.Environment (lookupEnv) import System.Exit (ExitCode (..)) +import System.Log.FastLogger (toLogStr) import System.Process (readProcessWithExitCode) import Test.Hspec import UnliftIO (async, bracket, cancel, link, throwIO, try, tryAny, withAsync, withSystemTempDirectory) @@ -273,12 +275,21 @@ go env -- | A logger that prints the log of the store if @HASKOIN_TEST_LOG@ is set, --- and discards it otherwise. +-- and discards it otherwise. Each line starts with the time it was logged +-- at, as seconds of the hour to the millisecond: what several stores do at +-- once can only be put in order, and a wait told from a hang, by the time. withTestLogger :: (Logger -> IO a) -> IO a withTestLogger f = lookupEnv "HASKOIN_TEST_LOG" >>= \case - Just v | v `notElem` ["", "0"] -> withLogger LevelDebug f + Just v | v `notElem` ["", "0"] -> withLogger LevelDebug (f . timed) _ -> f Logger {level = LevelError, source = "", push = \_ -> return ()} + where + timed l = l {push = \line -> stamp >>= \at -> l.push (at <> line)} :: Logger + stamp = do + now <- getPOSIXTime + let (seconds, millis) = (floor (now * 1000) `mod` 3600000 :: Int) `divMod` 1000 + padded = replicate (3 - length (show millis)) '0' <> show millis + return (toLogStr (show seconds <> "." <> padded <> " ")) -- | Store with the default gaps, caching every used xpub, with small RocksDB -- buffers and caches, as a member of a fleet or not. @@ -334,6 +345,7 @@ noXPub = False, noBlockchainInfo = False, healthCheckInterval = 5, + accessLog = False, tls = Nothing, logger = logger } @@ -1766,7 +1778,7 @@ -- its database, with the payment in the pool and after the block: the -- cache is brought to the block by whichever store moved the tip. fleetTest :: Env -> IO () -fleetTest env = withTestLogger $ \logger -> member logger $ \a urlA -> member logger $ \b urlB -> do +fleetTest env = member "A" $ \a urlA -> member "B" $ \b urlB -> do one <- maybe (fail "The store is not a member of a fleet") return a.fleet let x = newXPub env "fleet" DeriveNormal q = "?derive=" <> deriveParam x @@ -1883,10 +1895,18 @@ (_, health) <- getJSON urlA "/health" ((health ! "redis") ! "ok") `shouldBe` Bool True where - member logger f = withRamDir $ \dir -> - withStore (env.memberIn dir) $ \s -> + -- Both members and their web servers log through the logger of the + -- tests, each with its name in front of its lines. A logger of their + -- own would keep its lines in a buffer of its own, and they would be + -- printed out of step with the rest: when the fleet test failed, that + -- made a health check that was prompt look seconds late. + member name f = withRamDir $ \dir -> do + let config = env.memberIn dir + shared = config.logger + named = shared {push = \line -> shared.push (name <> " " <> line)} :: Logger + withStore ((config :: StoreConfig) {logger = named}) $ \s -> listening $ \(sock, port) -> - withAsync (runWebSocket (webConfig logger s) sock) $ \web -> + withAsync (runWebSocket (webConfig named s) sock) $ \web -> link web >> f s ("http://127.0.0.1:" <> show port) -- | Run a second store, with its own database, syncing from the same node diff --git a/test/Haskoin/Store/OutageSpec.hs b/test/Haskoin/Store/OutageSpec.hs new file mode 100644 --- /dev/null +++ b/test/Haskoin/Store/OutageSpec.hs @@ -0,0 +1,36 @@ +module Haskoin.Store.OutageSpec (spec) where + +import Control.Exception (ErrorCall (..), throwIO) +import Data.IORef (modifyIORef', newIORef, readIORef) +import Data.Text qualified as T +import Haskoin.Node (LogLevel (..)) +import Haskoin.Store.Outage +import Test.Hspec + +spec :: Spec +spec = describe "outage" $ do + it "says once that it started and once that it is over" $ do + said <- newIORef [] + outage <- newOutage + let note level text = modifyIORef' said ((level, text) :) + try' action = attempt outage note "reach the service" action + works = return () + fails = throwIO (ErrorCall "no route") + mapM try' [works, fails, fails, fails, works, works] `shouldReturn` [True, False, False, False, True, True] + heard <- reverse <$> readIORef said + map fst heard `shouldBe` [LevelWarn, LevelDebug, LevelDebug, LevelInfo] + -- what failed and why, and what works again + snd (heard !! 0) `shouldSatisfy` T.isPrefixOf "Could not reach the service: no route" + snd (last heard) `shouldBe` "Can reach the service again" + it "warns again at the next outage" $ do + said <- newIORef [] + outage <- newOutage + let note level _ = modifyIORef' said (level :) + fails = throwIO (ErrorCall "down") :: IO () + mapM_ (attempt outage note "reach the service") [fails, return (), fails] + (reverse <$> readIORef said) `shouldReturn` [LevelWarn, LevelInfo, LevelWarn] + it "gives the result of what worked, and nothing for what did not" $ do + outage <- newOutage + let quiet _ _ = return () + attempting outage quiet "count" (return (3 :: Int)) `shouldReturn` Just 3 + attempting outage quiet "count" (throwIO (ErrorCall "no") :: IO Int) `shouldReturn` Nothing diff --git a/test/Haskoin/Store/WebSpec.hs b/test/Haskoin/Store/WebSpec.hs --- a/test/Haskoin/Store/WebSpec.hs +++ b/test/Haskoin/Store/WebSpec.hs @@ -1,11 +1,26 @@ module Haskoin.Store.WebSpec (spec) where +import Control.Concurrent (threadDelay) import Data.ByteString (ByteString) import Data.Either (isLeft) +import Data.IORef (modifyIORef', newIORef, readIORef) import Data.Maybe (fromJust) +import Data.Text qualified as T import Data.Text.Encoding (decodeUtf8) import Haskoin (Tx (..), bch, btc, decodeHex, txHash, txHashToHex) -import Haskoin.Store.Web (acceptsBinary, decodeTxBody) +import Haskoin.Node (LogLevel (..), Logger (..)) +import Haskoin.Store.Data + ( BlockHealth (..), + CountHealth (..), + HealthCheck (..), + MaxHealth (..), + TimeHealth (..), + ) +import Haskoin.Store.Web (acceptsBinary, ailments, decodeTxBody, logIt) +import Network.HTTP.Types (status200, status404, status500, status503) +import Network.Wai (Request (..), defaultRequest, responseLBS) +import Network.Wai.Internal (ResponseReceived (..)) +import System.Log.FastLogger (fromLogStr) import Test.Hspec -- | A transaction written by hand, in the format without witness. It has @@ -31,8 +46,69 @@ \010101\ \00000000" +-- | What the log has after a request that is answered with a status, after +-- a number of milliseconds, by a server that warns of requests of a second. +logged :: Bool -> [T.Text] -> Int -> Int -> IO [T.Text] +logged access path status wait = do + said <- newIORef [] + let keep line = modifyIORef' said (decodeUtf8 (fromLogStr line) :) + logger = Logger {level = LevelDebug, source = "", push = keep} + answer = case status of + 200 -> status200 + 404 -> status404 + 503 -> status503 + _ -> status500 + app _ respond = threadDelay (wait * 1000) >> respond (responseLBS answer [] "") + _ <- logIt logger access 1 app defaultRequest {pathInfo = path} (\_ -> return ResponseReceived) + reverse <$> readIORef said + +-- | The level of each line of a log, as the line names it at its start. +levels :: [T.Text] -> [T.Text] +levels = map (T.takeWhile (`notElem` ['#', ']']) . T.drop 1) + +-- | A health check that passes. +well :: HealthCheck +well = + HealthCheck + { blocks = BlockHealth {headers = 100, blocks = 100, max = 3}, + lastBlock = TimeHealth {age = 60, max = 14400}, + lastTx = TimeHealth {age = 5, max = 1800}, + pendingTxs = MaxHealth {count = 0, max = 10000}, + peers = CountHealth {count = 8, min = 1}, + network = "btc", + version = "0", + time = 0, + redis = Nothing + } + spec :: Spec spec = do + describe "log of requests" $ do + it "has an error only for an error of the server" $ do + levels <$> logged False ["block", "best"] 200 0 `shouldReturn` ["Debug"] + levels <$> logged False ["address", "x"] 404 0 `shouldReturn` ["Debug"] + levels <$> logged False ["health"] 503 0 `shouldReturn` ["Debug"] + levels <$> logged False ["block", "best"] 500 0 `shouldReturn` ["Error"] + it "warns of a request that took long, and not of the stream of events" $ do + slow <- logged False ["xpub", "x"] 200 1100 + levels slow `shouldBe` ["Debug", "Warn"] + last slow `shouldSatisfy` T.isInfixOf "Slow request, 1.1 seconds: " + levels <$> logged False ["events"] 200 1100 `shouldReturn` ["Debug"] + it "has every request as information when the access log is on" $ do + lines' <- logged True ["block", "best"] 200 0 + levels lines' `shouldBe` ["Info"] + -- the address of the client, the request, the status and the time + last lines' `shouldSatisfy` T.isInfixOf "0.0.0.0:0 GET" + last lines' `shouldSatisfy` T.isInfixOf ": 200 OK, " + last lines' `shouldSatisfy` T.isSuffixOf " ms\n" + levels <$> logged True ["block", "best"] 500 0 `shouldReturn` ["Error"] + describe "ailments" $ do + it "names what fails of a health check" $ do + ailments well `shouldBe` "" + let behind = well {blocks = BlockHealth {headers = 105, blocks = 100, max = 3}} :: HealthCheck + alone = behind {peers = CountHealth {count = 0, min = 1}} :: HealthCheck + ailments behind `shouldBe` "5 blocks behind the headers" + ailments alone `shouldBe` "5 blocks behind the headers, 0 peers" describe "acceptsBinary" $ do it "takes the binary type by itself" $ acceptsBinary "application/octet-stream" `shouldBe` True