haskoin-store 1.9.0 → 1.9.1

raw patch · 21 files changed

+1144/−362 lines, 21 filesdep ~haskoin-nodePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: haskoin-node

API changes (from Hackage documentation)

Files

• CHANGELOG.md +72/−0
• README.md +312/−220
• app/Main.hs +19/−2
• bench/Main.hs +1/−0
• haskoin-store.cabal +9/−7
• src/Haskoin/Store/BlockStore.hs +4/−4
• src/Haskoin/Store/Cache.hs +10/−9
• src/Haskoin/Store/Fleet.hs +4/−1
• src/Haskoin/Store/Fleet/Member.hs +134/−49
• src/Haskoin/Store/Fleet/Redis.hs +48/−10
• src/Haskoin/Store/Fleet/lua/pool.lua +16/−7
• src/Haskoin/Store/Logic/Layered.hs +13/−8
• src/Haskoin/Store/Manager.hs +5/−8
• src/Haskoin/Store/Outage.hs +81/−0
• src/Haskoin/Store/Web.hs +157/−27
• swagger.yaml +1/−1
• test/Haskoin/Store/Fleet/MemberSpec.hs +91/−2
• test/Haskoin/Store/Fleet/RedisSpec.hs +28/−0
• test/Haskoin/Store/IntegrationSpec.hs +26/−6
• test/Haskoin/Store/OutageSpec.hs +36/−0
• test/Haskoin/Store/WebSpec.hs +77/−1

@@ -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

@@ -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/<pid>/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).

@@ -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"

@@ -144,6 +144,7 @@       noXPub = False,       noBlockchainInfo = False,       healthCheckInterval = 30,+      accessLog = False,       tls = Nothing,       logger = quiet     }

@@ -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

@@ -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.

@@ -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

@@ -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

@@ -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

@@ -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,

@@ -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

@@ -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

@@ -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 ::

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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