diff --git a/CHANGELOG.md b/CHANGELOG.md
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -4,6 +4,123 @@
 The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/)
 and this project adheres to [Semantic Versioning](http://semver.org/spec/v2.0.0.html).
 
+## [Unreleased]
+
+## [2.5.0] - 2026-11-10
+
+This release fixes the findings of a security review. Several fixes change
+the API; each is marked "Breaking" below.
+
+### Added
+
+- `Haskoin.Node.Block`, re-exported by `Haskoin.Node`: `blockMutation` tells
+  whether the transactions of a block are the ones its header commits to, as
+  `IsBlockMutated` in Bitcoin Core 32.1 does. `witnessCheck` and
+  `segWitHeight` choose the witness rule for a block from the height of its
+  parent.
+- `Haskoin.Node.Address.netGroup` and `NetGroup`: the network group of an
+  address, as Bitcoin Core forms it, and `connectTimeout`.
+- `Haskoin.Node.Chain.Sync`: `syncDeadline`, `syncTimedOut`, `askHeaders`,
+  `gotHeaders`, `mayAsk`, `headersResponseTime`, `headersSyncTimeoutBase` and
+  `headersSyncTimeoutPerHeader`, for the deadline of a turn and the requests
+  for headers in flight.
+- `Haskoin.Node.PeerMgr.Addresses`: the `Seeded` source and `addressSource`.
+
+### Security
+
+- Blocks are checked against their headers. A peer could answer a request for
+  a block with the real header, and its proof of work, together with
+  transactions of its choice, and `getBlocks`, `getData` and the `MBlock`
+  events passed them on. Applications such as Haskoin Store would then record
+  payments that never happened. Every block a peer sends now has to pass
+  `blockMutation`: the transaction ids hash to the Merkle root, the tree does
+  not repeat transactions (CVE-2012-2459), a block without a coinbase holds no
+  64-byte transaction, and, once SegWit is active at the block's height, the
+  witness data matches the commitment in the coinbase. A peer that sends a
+  block that fails is disconnected with `MutatedBlock`. The header is not
+  marked invalid. When the node does not know the parent of a block, the
+  witness data is not checked, as in Bitcoin Core.
+- One peer could hold the header sync forever. It kept its turn as long as it
+  sent full batches, even of headers the node already had, and no other peer
+  was asked. Now a full batch that brings no new header ends the turn, a turn
+  that runs past the deadline Bitcoin Core gives its initial headers sync (15
+  minutes plus 1 millisecond per block expected since the best header) ends
+  with the peer dropped when another peer can take over, and a peer that
+  announces an unknown block is asked for headers at once, with at most one
+  request in flight per peer, as in Bitcoin Core.
+- Reading a message took time that grew with the square of its size when it
+  arrived in small pieces. A peer could keep a core busy for seconds with one
+  4 MB message, and for about a minute with a 64 MB Bitcoin Cash block
+  message. Reading is now linear.
+- One IP address could take every outbound slot. Addresses were tried in the
+  order of their port, any number of connections could go to one network, and
+  a book full of gossip learned no new seed address. Learned addresses are now
+  picked at random, at most one connection goes to each network group (a /16
+  of IPv4, a /32 of IPv6) unless the address is configured, seed addresses
+  have their own room, and a new address can replace one that failed.
+- Messages from a peer that had not completed the handshake were published to
+  the application, outside back-pressure. They are now dropped, except the
+  `version` and `verack` messages, as Bitcoin Core does.
+- Addresses returned by DNS seeds must be routable, like relayed addresses,
+  and the ORCHID ranges `2001:10::/28` and `2001:20::/28` are no longer
+  routable, as in Bitcoin Core.
+- On networks with SegWit, a peer must offer `NODE_WITNESS`, as Bitcoin Core
+  requires of its outbound peers. The node asks for blocks and transactions
+  with their witness, which such a peer cannot serve.
+- `withConnection` gives up on a connection that does not open within five
+  seconds. A relayed address that dropped connection requests held a slot for
+  about two minutes.
+
+### Changed
+
+- Allow `rocksdb-haskell-jprupp` 2.7, which adds iterators that stop at a
+  bound. Nothing in this package changes with it: version 2.7 is a new
+  major version only because the `DB` record gained a field, and this
+  package gets its `DB` from `withDBCF`. It is built and tested with 2.7.1,
+  and versions from 2.6.1 on are still allowed.
+- Breaking: `PeerConfig` and `PeerMgrConfig` have a `lookupBlock` field, the
+  function that finds a stored header. A peer uses it to tell whether SegWit
+  applies to a block it receives. `withNode` fills it in; code that builds
+  these records itself must add it. A function that always gives `Nothing`
+  keeps the Merkle root check but skips the witness check.
+- Breaking: `PeerException` has a `MutatedBlock` constructor, and
+  `HandshakeError` a `NotWitnessNode` one.
+- Breaking: `checkVersion` takes the network.
+- Breaking: `takeAddress` takes a random number and a predicate that says
+  which seed and gossiped addresses may be taken. Configured addresses come
+  first. `Source` has a `Seeded` constructor, and the peer manager adds seed
+  addresses with it.
+- Breaking: `startSync` takes the deadline of the turn.
+- On regtest, the DNS seed of haskoin-core is `localhost`, which is not
+  routable, so discovery no longer finds a local node. Configure local peers
+  in `peers`.
+- When a batch of headers fails after some valid headers, the node keeps the
+  valid ones, as before, and now publishes the `ChainBestBlock` event for the
+  best block they set.
+- Counting the gossiped addresses in the book no longer scans it for every
+  new address.
+- The library depends on streaming-commons directly, for the TCP connection
+  that `withConnection` opens. It was already a dependency of conduit-extra.
+- The documentation says that a subscriber that falls behind holds memory,
+  that witness data from `getTxs` and `MTx` events is not authenticated, and
+  that headers below the minimum chain work are stored during the initial
+  sync.
+- The README quick start compiles again: it needed `DisambiguateRecordFields`
+  and the fields of `BlockNode`. The tutorial names the imports it adds.
+- Tests: the Bitcoin Core blocks used as fixtures, the limits of inventory,
+  locator and user agent sizes, back-pressure, the edges of the tip age and of
+  the maximum life, reserved address ranges, and ties between forks of equal
+  work are tested. Mock peers send their test messages once they are online,
+  which ends a race that made some tests time out or hang.
+- The CI workflow's shell steps moved into `scripts/check-local-deps.sh` and
+  `scripts/install-system-libraries.sh`, and the regtest Containerfile's
+  install step into `test/regtest/install-nodes.sh`, so each can be read and
+  run on its own. The package description in `package.yaml` keeps its line
+  breaks, so the generated cabal file has shorter lines.
+- The instructions for contributors and for Claude ask for lines of code
+  shorter than 120 columns and for scripts in their own files.
+- The README shows a badge with the status of CI on `master`.
+
 ## [2.4.0] - 2026-11-09
 
 ### Added
diff --git a/README.md b/README.md
--- a/README.md
+++ b/README.md
@@ -1,5 +1,6 @@
 # Haskoin Node
 
+[![CI](https://github.com/jprupp/haskoin-node/actions/workflows/ci.yml/badge.svg)](https://github.com/jprupp/haskoin-node/actions/workflows/ci.yml)
 [![Hackage](https://img.shields.io/hackage/v/haskoin-node.svg)](https://hackage.haskell.org/package/haskoin-node)
 [![License: MIT](https://img.shields.io/badge/license-MIT-blue.svg)](https://github.com/jprupp/haskoin-node/blob/master/LICENSE)
 
@@ -62,8 +63,11 @@
   publisher. The application subscribes and reacts; the node never needs to know
   who is listening.
 - **Peers are strangers.** Message sizes are checked before payloads are read,
-  anything invalid ends the connection, relayed addresses are filtered, and a
-  peer cannot push data faster than the node can handle it.
+  a payload costs time linear in its size however it is split, anything
+  invalid ends the connection, a block must hold the transactions its header
+  commits to, relayed addresses are filtered and spread over network groups,
+  and the node reads a peer only as fast as it handles its messages. Your
+  subscribers are not throttled: one that falls behind holds memory.
 - **Prefer good peers, but keep moving.** Peers are ranked by measured latency
   so the fastest are used first, and every connection is eventually replaced so
   the node never depends on the same few peers forever.
@@ -79,9 +83,12 @@
   no `MonadIO` or `MonadUnliftIO` constraints. Types say exactly what runs, GHC
   has nothing to specialise, and long-running loops cannot leak through an
   unspecialised dictionary. From your own monad, call the node with `liftIO`.
-- **Never stuck.** Every hint that a peer has blocks the node lacks makes it ask
-  for headers, and a quiet period makes it ask every peer, so a missed
-  announcement cannot leave the chain behind.
+- **Keep moving.** Every hint that a peer has blocks the node lacks makes it
+  ask that peer for headers, at once even while another peer syncs, and a
+  quiet period makes it ask every peer, so a missed announcement cannot leave
+  the chain behind. A syncing peer loses its turn when it sends nothing new,
+  and when it runs past the deadline that Bitcoin Core gives its initial
+  headers sync.
 
 ## Features
 
@@ -89,11 +96,11 @@
 | --------------- | ---------------------------------------------------------------------------------------------- |
 | Networks        | Every network of haskoin-core: Bitcoin and Bitcoin Cash mainnet, testnets and regtest           |
 | Peer discovery  | DNS seeds and addresses relayed by peers, or a static list of peers                             |
-| Peer management | Version handshake, ping-based latency, peers sorted by median ping, rotation after a maximum age, retry backoff and bans for bad addresses |
-| Header sync     | Headers downloaded from one peer at a time, connected to the chain with the most work, stored in RocksDB; new blocks followed whether peers announce them with headers or inventory, and peers polled after a quiet period |
+| Peer management | Version handshake, ping-based latency, peers sorted by median ping, rotation after a maximum age, retry backoff and bans for bad addresses, random choice among learned addresses with one connection per network group |
+| Header sync     | Headers downloaded from one peer at a time, with a deadline per turn, connected to the chain with the most work, stored in RocksDB; new blocks followed whether peers announce them with headers or inventory, announcing peers asked at once, and peers polled after a quiet period |
 | Events          | Best header changes, sync completion, peer connections and every message received              |
-| Data requests   | Fetch blocks and transactions from a peer, with a timeout                                       |
-| Protection      | Strict parsing, per-command size limits, back-pressure, bounded address pool, explicit handshake states |
+| Data requests   | Fetch blocks and transactions from a peer, with a timeout; every block checked against its header's Merkle root and witness commitment |
+| Protection      | Strict parsing, per-command size limits, linear-time reads, back-pressure, bounded address pool, explicit handshake states, connect timeout |
 
 ### What is not included
 
@@ -162,11 +169,11 @@
 
 ```yaml
 extra-deps:
-  - haskoin-node-2.4.0
+  - haskoin-node-2.5.0
   - haskoin-core-1.6.1
   - secp256k1-haskell-2.0.1
   - base16-2.0
-  - rocksdb-haskell-jprupp-2.6.1
+  - rocksdb-haskell-jprupp-2.7.1
   - rocksdb-query-0.6.1
   - nqe-0.6.9
 ```
@@ -201,13 +208,14 @@
 This program connects to Bitcoin, syncs headers, and prints what happens:
 
 ```haskell
+{-# LANGUAGE DisambiguateRecordFields #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedRecordDot #-}
 
 import Control.Monad (forever)
 import Data.Default (def)
 import Database.RocksDB (Config (..), withDB)
-import Haskoin (NetworkAddress (..), btc, sockToHostAddress)
+import Haskoin (BlockNode (..), NetworkAddress (..), btc, sockToHostAddress)
 import Haskoin.Node
 import NQE (receive, withPublisher, withSubscription)
 import Network.Socket (SockAddr (..))
@@ -301,7 +309,8 @@
 ### 4. Put it together
 
 Use the configuration from the [quick start](#quick-start), and run the watcher
-inside `withNode`:
+inside `withNode`. Besides the imports of the quick start, the watcher needs
+`Block (..)`, `Network` and `headerHash` from `Haskoin`, and `Inbox` from `NQE`:
 
 ```haskell
 withNode cfg $ \node -> do
@@ -324,13 +333,17 @@
 
 - The **peer manager** (`Haskoin.Node.PeerMgr`) finds peer addresses, connects
   to them, does the version handshake, pings them, and drops those that are slow,
-  silent, misbehaving or too old. An address whose connection failed is tried
-  again later each time, and one whose peer misbehaved waits a day.
+  silent, misbehaving or too old. Configured peers are tried first; learned
+  addresses are picked at random, at most one per network group. An address
+  whose connection failed is tried again later each time, and one whose peer
+  misbehaved waits a day.
 - The **chain** (`Haskoin.Node.Chain`) asks one peer at a time for headers,
   connects them to the headers it has, follows the chain with the most work, and
   stores the headers in RocksDB. It asks a peer for headers whenever the peer
-  announces blocks it does not know, with headers or with inventory, and asks
-  every peer when it has heard nothing for `timeout` seconds.
+  announces blocks it does not know, with headers or with inventory, at once if
+  another peer holds the turn, and asks every peer when it has heard nothing
+  for `timeout` seconds. A turn ends when the peer has nothing more, sends a
+  full batch with nothing new, or runs past its deadline.
 
 The rules for talking to peers are pure state machines, each in its own module:
 
@@ -346,6 +359,10 @@
 The processes store the state and carry out what a transition says. Time is an
 input to the transitions, so every timing rule is tested without waiting.
 
+`Haskoin.Node.Block` is a pure check of another kind: whether the
+transactions of a block are the ones its header commits to. Every block a peer
+sends passes through it.
+
 Each peer connection is its own process (`Haskoin.Node.Peer`), run by a
 supervisor inside the peer manager.
 
@@ -359,8 +376,15 @@
 | `ChainEvent (ChainSynced node)`         | Headers caught up with the network (once)               |
 | `PeerEvent (PeerConnected peer)`        | A peer finished the handshake                           |
 | `PeerEvent (PeerDisconnected peer)`     | An online peer went away                                |
-| `PeerEvent (PeerMessage peer msg)`      | A peer sent a message: `MInv`, `MBlock`, `MTx` and so on |
+| `PeerEvent (PeerMessage peer msg)`      | An online peer sent a message: `MInv`, `MBlock`, `MTx` and so on |
 
+Messages are published only from peers that are online, except `version` and
+`verack`, which are the handshake itself. A block in an `MBlock` message has
+passed `blockMutation`: its transactions hash to the Merkle root of its header,
+and its witness data matches its coinbase when the node knows its parent.
+Nothing else about it is checked, and a transaction in an `MTx` message is not
+checked at all.
+
 "In sync" means the best header is less than two hours old, has at least the
 minimum chain work of the network, and no peer is left to sync from.
 
@@ -368,8 +392,10 @@
 
 A peer may have at most 16 messages published and not yet handled by the node.
 Past that, the node stops reading its socket, so a fast peer fills its own TCP
-window instead of the node's memory. Your subscriber should keep reading events;
-a subscription that falls far behind holds memory.
+window instead of the node's memory. The node does not wait for your
+subscriber, though: a subscription is an unbounded queue, and one that falls
+behind holds every event it has not read. Keep reading events, and hand slow
+work to another thread.
 
 ### Database layout
 
@@ -404,6 +430,13 @@
 everything, in order, before the timeout in seconds. Unrelated messages that the
 peer sends in between are ignored. `pingPeer` measures a round trip.
 
+A block that `getBlocks` returns holds the transactions its header commits to.
+A peer that sends another block under the requested header is disconnected,
+and the request gives `Nothing` when it times out. The transactions are not
+validated otherwise. A transaction from `getTxs` is matched by its id, which
+does not cover its witness, so treat its witness data as unauthenticated until
+you find the transaction in a block.
+
 `getPeers` leaves out peers that are being disconnected, even before their
 connection closes.
 
@@ -445,11 +478,16 @@
 
 A peer without a port uses the default port of the network.
 
+Addresses from DNS seeds must be public, like relayed addresses. On regtest the
+seed of haskoin-core is `localhost`, which is not, so list local peers in
+`peers` instead of relying on discovery.
+
 ### Custom connections
 
 `connect` decides how to open a connection. `withConnection` opens a plain TCP
-socket. Replace it to go through a proxy, or to plug in mock peers in tests, as
-the test suite does.
+socket, and gives up if it does not open within five seconds (`connectTimeout`,
+as in Bitcoin Core). Replace it to go through a proxy, or to plug in mock peers
+in tests, as the test suite does.
 
 ### Logging
 
@@ -482,6 +520,7 @@
 | -------------- | --------------------------------------------------------------------------- |
 | Node           | `NodeConfig`, `NodeEvent`, `Node`, `withNode`, `withConnection`              |
 | Peers          | `Peer`, `PeerEvent`, `PeerException`, `sendMessage`, `getBlocks`, `getTxs`, `getData`, `pingPeer`, `killPeer`, `newOwner`, `reservePeer`, `releasePeer` |
+| Blocks         | `blockMutation`, `BlockMutation`, `witnessCheck`, `WitnessCheck`, `segWitHeight` |
 | Peer manager   | `PeerMgr`, `OnlinePeer`, `PeerState`, `Stage`, `DisconnectReason`, `getPeers`, `getOnlinePeer`, `toSockAddr`, `isRoutable` |
 | Chain          | `Chain`, `ChainEvent`, `chainGetBest`, `chainGetBlock`, `chainGetAncestor`, `chainGetParents`, `chainGetSplitBlock`, `chainBlockMain`, `chainIsSynced`, `chainRunHeaders` |
 | Logging        | `Logger`, `LogLevel`, `withLogger`, `withSource`, `logDebug` ... `logError`  |
@@ -496,6 +535,7 @@
 | `Haskoin.Node.Peer`              | The process that talks to one peer, and data requests       |
 | `Haskoin.Node.Peer.Request`      | State machine for receiving requested blocks and transactions |
 | `Haskoin.Node.Peer.Lock`         | State machine for reserving a peer                          |
+| `Haskoin.Node.Block`             | Whether a block holds the transactions its header commits to |
 | `Haskoin.Node.PeerMgr`           | Finds, connects, ranks and drops peers                      |
 | `Haskoin.Node.PeerMgr.Lifecycle` | State machine for the life of a connection                  |
 | `Haskoin.Node.PeerMgr.Handshake` | State machine for the version handshake                     |
@@ -503,27 +543,49 @@
 | `Haskoin.Node.Chain`             | Keeps the header chain in sync                              |
 | `Haskoin.Node.Chain.Sync`        | State machine that decides which peer to ask for headers, and when the chain is synced |
 | `Haskoin.Node.Chain.Database`    | Storage of headers in RocksDB                               |
-| `Haskoin.Node.Address`           | Parsing peer addresses and opening connections              |
+| `Haskoin.Node.Address`           | Parsing peer addresses, network groups and opening connections |
 | `Haskoin.Node.Logger`            | Logging                                                     |
 
 ## Security notes
 
 - Every message header is checked before its payload is read. The payload limit
-  is the `maxPayloadSize` of the command on the network: on Bitcoin Cash, 2 MiB
-  for everything but block messages.
+  is the `maxPayloadSize` of the command on the network: 4,000,000 bytes on
+  Bitcoin, and on Bitcoin Cash 2 MiB for everything but block messages.
+- Reading a payload costs time and memory linear in its size, however small
+  the pieces it arrives in.
 - List messages are refused as soon as their count is over the limit, such as
-  2000 headers, 1000 addresses or 50000 inventory entries.
+  2000 headers, 1000 addresses, 50000 inventory entries or 101 locator hashes.
 - A peer that sends anything invalid is disconnected, with a `PeerException`
   saying why.
+- A peer that sends a block whose transactions are not the ones its header
+  commits to is disconnected (`MutatedBlock`). The check is Bitcoin Core's
+  `IsBlockMutated`: the Merkle root, a tree that repeats transactions
+  (CVE-2012-2459), and, once SegWit is active at the block's height, the
+  witness commitment. The header itself is not marked invalid. When the node
+  does not know the parent of a block, its witness data is not checked.
+- Messages from a peer that has not completed the handshake are not acted on
+  or published, except the handshake messages.
+- On Bitcoin, a peer must offer witness data (`NODE_WITNESS`) as well as the
+  full chain, as Bitcoin Core requires of its outbound peers.
 - A peer that sends a second version or verack, or does not complete the
   handshake within `timeout` seconds even while sending other messages, is
   disconnected.
 - A peer that sends invalid headers, or does not answer a request for headers in
   time, is never asked for headers again before it disconnects.
-- Addresses relayed by peers are only used if they are public unicast
-  addresses, so a peer cannot make the node connect to services on its own host
-  or network. Static peers are not checked.
-- At most 4096 relayed addresses are kept.
+- A syncing peer whose full batch of headers brings nothing new loses its
+  turn. One that is still syncing after 15 minutes plus 1 millisecond for each
+  block expected since the best header is disconnected when another peer can
+  take over, as Bitcoin Core does.
+- Addresses relayed by peers and returned by DNS seeds are only used if they
+  are public unicast addresses, so a peer or a resolver cannot make the node
+  connect to services on its own host or network. Static peers are not checked.
+- Learned addresses are picked at random, and at most one connection is open to
+  each network group (a /16 of IPv4, a /32 of IPv6), so one operator cannot take
+  every slot. Static peers are exempt.
+- At most 4096 relayed addresses and 4096 seed addresses are kept, apart, so
+  gossip cannot crowd out the seeds. When the room for one is full, a new
+  address replaces one that has failed to connect.
+- A connection that does not open within five seconds is given up.
 - An address whose connection fails waits twice as long after each failure
   before it is tried again, up to ten minutes. A relayed address whose peer
   broke the protocol is not tried again for a day. Static peers are never
@@ -531,8 +593,13 @@
 - Headers are not reported as synced until they have the minimum chain work of
   the network. Above that work, forks from far below the tip on a chain with
   less work are refused.
-- The node trusts the chain with the most work. It does not validate blocks:
-  check the data you get from peers before relying on it.
+- Below that work, during the initial sync, every valid header is stored. A
+  peer can make the node store a fork of low difficulty, at the cost of its
+  proof of work. Bitcoin Core first checks that a peer's headers reach the
+  minimum work before it stores any; this node does not yet.
+- The node trusts the chain with the most work. It checks that a block holds
+  the transactions its header commits to, but does not validate the block:
+  check the transactions you get from peers before relying on them.
 
 ## Development
 
@@ -569,8 +636,9 @@
   [Bitcoin Core](https://bitcoincore.org) and
   [Bitcoin Cash Node](https://bitcoincashnode.org) in regression test mode. The
   nodes run in a [Podman](https://podman.io) container built from
-  `test/regtest/Containerfile`, which installs the official release binaries on
-  Ubuntu after checking their SHA-256 hashes. The image is built the first time
+  `test/regtest/Containerfile`, whose script `test/regtest/install-nodes.sh`
+  installs the official release binaries on Ubuntu after checking their SHA-256
+  hashes. The image is built the first time
   the suite runs. Nodes use random ports, so runs do not collide. The suite is
   skipped if Podman is missing or `HASKOIN_NODE_SKIP_REGTEST` is set.
 
@@ -580,12 +648,22 @@
 
 Set `HASKOIN_TEST_LOG` to see the node's logs while tests run.
 
+CI builds and tests every change with the OS libraries, with `stack --nix`,
+and against the regtest nodes. Its steps call the scripts in `scripts/`, which
+you can also run locally: `scripts/check-local-deps.sh` fails if `stack.yaml`
+points at a package outside the repository, which CI cannot build, and
+`scripts/install-system-libraries.sh` installs the C libraries on Ubuntu.
+
 ### Contributing
 
 Pull requests are welcome.
 
 - Format the code with [Ormolu](https://github.com/tweag/ormolu).
 - Add tests for the behaviour you change.
+- Keep lines of code, including scripts, workflows and the examples in the
+  documentation, shorter than 120 columns.
+- Put multi-line scripts in their own files rather than embedding them in a
+  workflow or a Containerfile.
 - Describe the change under a new version in `CHANGELOG.md`. The file follows
   [Keep a Changelog](https://keepachangelog.com/en/1.0.0/), and versions follow
   [Semantic Versioning](https://semver.org/).
diff --git a/haskoin-node.cabal b/haskoin-node.cabal
--- a/haskoin-node.cabal
+++ b/haskoin-node.cabal
@@ -5,9 +5,12 @@
 -- see: https://github.com/sol/hpack
 
 name:           haskoin-node
-version:        2.4.0
+version:        2.5.0
 synopsis:       P2P library for Bitcoin and Bitcoin Cash
-description:    Connect to Bitcoin (BTC) and Bitcoin Cash (BCH) peers, keep them healthy, and sync block headers into a RocksDB database. Blocks and transactions can be downloaded from connected peers. See the README on GitHub at <https://github.com/jprupp/haskoin-node#readme>.
+description:    Connect to Bitcoin (BTC) and Bitcoin Cash (BCH) peers, keep them healthy, and
+                sync block headers into a RocksDB database. Blocks and transactions can be
+                downloaded from connected peers. See the README on GitHub at
+                <https://github.com/jprupp/haskoin-node#readme>.
 category:       Bitcoin, Finance, Network
 homepage:       https://github.com/jprupp/haskoin-node#readme
 bug-reports:    https://github.com/jprupp/haskoin-node/issues
@@ -21,6 +24,7 @@
     GHC == 9.12.4
 extra-source-files:
     test/regtest/Containerfile
+    test/regtest/install-nodes.sh
 extra-doc-files:
     README.md
     CHANGELOG.md
@@ -33,6 +37,7 @@
   exposed-modules:
       Haskoin.Node
       Haskoin.Node.Address
+      Haskoin.Node.Block
       Haskoin.Node.Chain
       Haskoin.Node.Chain.Database
       Haskoin.Node.Chain.Sync
@@ -67,9 +72,10 @@
     , network >=3.1 && <3.3
     , nqe >=0.6.9 && <0.7
     , random >=1.2 && <1.4
-    , rocksdb-haskell-jprupp >=2.6.1 && <2.7
+    , rocksdb-haskell-jprupp >=2.6.1 && <2.8
     , rocksdb-query >=0.6.1 && <0.7
     , stm ==2.5.*
+    , streaming-commons ==0.2.*
     , string-conversions ==0.4.*
     , text >=2.0 && <2.2
     , time >=1.12 && <1.15
@@ -109,6 +115,7 @@
     , process
     , random
     , rocksdb-haskell-jprupp
+    , text
     , time
     , unliftio
   default-language: GHC2024
@@ -118,6 +125,7 @@
   main-is: Spec.hs
   other-modules:
       Haskoin.Node.AddressSpec
+      Haskoin.Node.BlockSpec
       Haskoin.Node.Chain.SyncSpec
       Haskoin.Node.ChainSpec
       Haskoin.Node.Peer.LockSpec
diff --git a/src/Haskoin/Node.hs b/src/Haskoin/Node.hs
--- a/src/Haskoin/Node.hs
+++ b/src/Haskoin/Node.hs
@@ -28,8 +28,11 @@
 --
 -- Everything that happens is published as a 'NodeEvent' to the 'Publisher'
 -- given in 'NodeConfig'. Subscribe to it to learn about new best blocks, peers
--- connecting and disconnecting, and every message received from a peer, such as
--- inventory announcements, blocks and transactions.
+-- connecting and disconnecting, and every message received from an online
+-- peer, such as inventory announcements, blocks and transactions. A
+-- subscription is an unbounded queue: the node does not wait for a slow
+-- subscriber, so a subscriber that falls behind holds every event it has not
+-- read in memory.
 --
 -- = Purpose
 --
@@ -67,8 +70,11 @@
 --
 -- * __Trust nothing from the network.__ Peers are strangers. Every message is
 --   checked against size limits before it is read, invalid input disconnects
---   the peer, and a peer cannot make the node allocate memory faster than it
---   can work.
+--   the peer, every block must hold the transactions its header commits to
+--   ("Haskoin.Node.Block"), and a peer cannot make the node allocate memory
+--   faster than it can work. The node's subscribers are another matter: the
+--   node does not wait for them, so a subscriber must keep up with what it
+--   asked for.
 --
 -- = Example
 --
@@ -117,6 +123,9 @@
     -- * Peers
     module Haskoin.Node.Peer,
 
+    -- * Blocks
+    module Haskoin.Node.Block,
+
     -- * Peer manager
     module Haskoin.Node.PeerMgr,
 
@@ -133,6 +142,7 @@
 import Database.RocksDB (ColumnFamily, DB)
 import Haskoin
 import Haskoin.Node.Address (withConnection)
+import Haskoin.Node.Block
 import Haskoin.Node.Chain
 import Haskoin.Node.Logger
 import Haskoin.Node.Loop (loopForever)
@@ -205,23 +215,33 @@
     _ -> return ()
   publish (ChainEvent event) output
 
--- | Route events from peers to the peer manager and chain. A message from a
--- peer is handled to completion before the peer may send another one past its
--- small allowance of pending messages (see 'maxPendingMessages'), so that the
--- node's queues cannot grow faster than it can work. Address, header and
--- inventory messages are only taken from peers that are online: the handshake
--- is complete and the peer is not being disconnected.
--- Inventory with blocks goes to the chain, which asks for headers if it does
--- not know them.
+-- | Route events from peers to the peer manager and chain, and publish them
+-- to the application.
+--
+-- A message from a peer is handled to completion before the peer may send
+-- another one past its small allowance of pending messages (see
+-- 'maxPendingMessages'), so that the node's own queues cannot grow faster
+-- than it can work. Address, header and inventory messages are only taken
+-- from peers that are online: the handshake is complete and the peer is not
+-- being disconnected. Inventory with blocks goes to the chain, which asks for
+-- headers if it does not know them.
+--
+-- Messages reach the application only from online peers, except @version@
+-- and @verack@, which are the handshake itself. Bitcoin Core ignores
+-- anything else a peer sends before the handshake is done, and so does the
+-- node: a peer whose version may still be refused cannot feed the
+-- application blocks and transactions.
 peerEvents ::
   Chain -> PeerMgr -> Inbox PeerEvent -> Publisher NodeEvent -> IO ()
 peerEvents ch mgr input output = loopForever $ do
   event <- receive input
   case event of
-    PeerConnected p ->
+    PeerConnected p -> do
       chainPeerConnected ch p
-    PeerDisconnected p ->
+      forward event
+    PeerDisconnected p -> do
       chainPeerDisconnected ch p
+      forward event
     PeerMessage p m -> do
       case m of
         MVersion v ->
@@ -241,14 +261,19 @@
           bhs -> whenOnline p $ chainBlocksAnnounced ch p bhs >> chainSync ch
         _ -> return ()
       ticklePeer mgr p
+      if handshake m then forward event else whenOnline p (forward event)
       peerMessageDone p
-  publish (PeerEvent event) output
   where
+    forward event = publish (PeerEvent event) output
     whenOnline p act =
       getOnlinePeer mgr p >>= \case
         Just o | o.online -> act
         _ -> return ()
     isBlock iv = iv.invType `elem` [InvBlock, InvWitnessBlock]
+    handshake = \case
+      MVersion _ -> True
+      MVerAck -> True
+      _ -> False
 
 -- | Launch node process in the foreground.
 --
@@ -263,7 +288,7 @@
       withPublisher $ \chainPub ->
         withSubscription chainPub $ \chainSub ->
           withChain (chainConfig chainPub) $ \chain ->
-            withPeerMgr (peerMgrConfig peerPub) $ \peerMgr ->
+            withPeerMgr (peerMgrConfig chain peerPub) $ \peerMgr ->
               withAsync (chainEvents peerMgr chainSub cfg.pub) $ \a1 ->
                 withAsync (peerEvents chain peerMgr peerSub cfg.pub) $ \a2 -> do
                   link a1
@@ -279,7 +304,7 @@
           timeout = cfg.timeout,
           logger = withSource "Chain" cfg.logger
         }
-    peerMgrConfig pub =
+    peerMgrConfig chain pub =
       PeerMgrConfig
         { maxPeers = cfg.maxPeers,
           peers = cfg.peers,
@@ -290,5 +315,6 @@
           timeout = cfg.timeout,
           maxPeerLife = cfg.maxPeerLife,
           connect = cfg.connect,
-          logger = withSource "PeerMgr" cfg.logger
+          logger = withSource "PeerMgr" cfg.logger,
+          lookupBlock = chainGetBlock chain
         }
diff --git a/src/Haskoin/Node/Address.hs b/src/Haskoin/Node/Address.hs
--- a/src/Haskoin/Node/Address.hs
+++ b/src/Haskoin/Node/Address.hs
@@ -17,35 +17,44 @@
   ( toHostService,
     toSockAddr,
     isRoutable,
+    NetGroup (..),
+    netGroup,
     withConnection,
+    connectTimeout,
   )
 where
 
 import Control.Applicative ((<|>))
 import Control.Arrow (second)
 import Control.Exception (IOException, catch)
-import Data.Bits ((.&.))
-import Data.Conduit.Network
-  ( ClientSettings,
-    appSink,
-    appSource,
-    clientSettings,
-    runTCPClient,
-  )
+import Data.Bits (complement, shiftR, (.&.), (.|.))
+import Conduit (liftIO, yield)
+import Control.Exception (finally)
+import Control.Monad (unless)
+import Data.ByteString (ByteString)
+import Data.ByteString qualified as B
+import Data.Conduit.Network (sinkSocket)
+import Data.Streaming.Network (clientSettingsTCP, getReadBufferSize, getSocketFamilyTCP)
+import Data.Time.Clock (NominalDiffTime)
 import Data.List (elemIndex)
 import Data.String.Conversions (cs)
-import Data.Word (Word8)
+import Data.Word (Word16, Word8)
 import Haskoin (Network (..))
 import Haskoin.Node.Peer (Conduits (..), WithConnection)
 import Network.Socket
   ( AddrInfo (..),
+    Family (AF_UNSPEC),
     NameInfoFlag (..),
     SockAddr (..),
+    close,
     getAddrInfo,
     getNameInfo,
     hostAddress6ToTuple,
     hostAddressToTuple,
+    tupleToHostAddress6,
   )
+import Network.Socket.ByteString (recv)
+import System.Timeout (timeout)
 import Text.Read (readMaybe)
 
 -- | Split a peer address into host and port. Accepts @host@, @host:port@,
@@ -89,11 +98,14 @@
     (host, srv) =
       second (<|> Just (show net.defaultPort)) (toHostService str)
 
--- | Whether an address that a peer relayed is worth connecting to: a public
--- unicast address with a port. Loopback, private, link-local, shared,
--- documentation, multicast and reserved ranges are refused, so that a peer
--- cannot make the node connect to services on its own host or network.
--- Static peers in the configuration are not checked.
+-- | Whether an address that a peer relayed, or that a DNS seed returned, is
+-- worth connecting to: a public unicast address with a port. Loopback,
+-- private, link-local, shared, documentation, multicast and reserved ranges
+-- are refused, so that a peer or a resolver cannot make the node connect to
+-- services on its own host or network. So are the ORCHID ranges
+-- @2001:10::\/28@ and @2001:20::\/28@, which Bitcoin Core 32.1 refuses too
+-- (@IsRFC4843@ and @IsRFC7343@). Static peers in the configuration are not
+-- checked.
 isRoutable :: SockAddr -> Bool
 isRoutable (SockAddrInet port h) =
   port /= 0 && routable4 (hostAddressToTuple h)
@@ -113,9 +125,65 @@
       | a .&. 0xffc0 == 0xfec0 -> False -- site-local
       | a .&. 0xff00 == 0xff00 -> False -- multicast
       | a == 0x2001 && b == 0x0db8 -> False -- documentation
+      | a == 0x2001 && b .&. 0xfff0 == 0x0010 -> False -- ORCHID
+      | a == 0x2001 && b .&. 0xfff0 == 0x0020 -> False -- ORCHIDv2
       | otherwise -> True
 isRoutable _ = False
 
+-- | A group of addresses that one operator can easily hold many of, from the
+-- same block of a network. The node opens at most one connection to each
+-- group from the addresses it learned, so that one operator cannot take every
+-- slot by gossiping many addresses of its own.
+data NetGroup
+  = -- | loopback addresses
+    LocalGroup
+  | -- | other addresses that are not routable
+    UnroutableGroup
+  | -- | an IPv4 address, or an IPv6 address that carries one, by its first
+    -- two bytes (a /16)
+    IPv4Group !Word8 !Word8
+  | -- | another IPv6 address, by its first four bytes (a /32), or its first
+    -- four and a half for Hurricane Electric (a /36)
+    IPv6Group ![Word8]
+  deriving stock (Eq, Ord, Show)
+
+-- | The network group of an address, as @NetGroupManager::GetGroup@ in
+-- Bitcoin Core 32.1 forms it without an AS map. The port does not count.
+--
+-- IPv4 addresses are grouped by /16. So are IPv6 addresses that carry an
+-- IPv4 address, by that address: IPv4-mapped (@::ffff:0:0\/96@), NAT64
+-- (@64:ff9b::\/96@), SIIT (@::ffff:0:0:0\/96@), 6to4 (@2002::\/16@) and
+-- Teredo (@2001::\/32@, with the bits of the address inverted). Hurricane
+-- Electric (@2001:470::\/32@) is grouped by /36, and the rest of IPv6 by
+-- /32.
+netGroup :: SockAddr -> NetGroup
+netGroup = \case
+  SockAddrInet _ h -> v4 (hostAddressToTuple h)
+  SockAddrInet6 _ _ h _ -> v6 (hostAddress6ToTuple h)
+  _ -> UnroutableGroup
+  where
+    v4 t@(a, b, _, _)
+      | a == 127 || a == 0 = LocalGroup
+      | not (routable4 t) = UnroutableGroup
+      | otherwise = IPv4Group a b
+    v6 t@(a, b, c, d, e, f, g, h)
+      | t == (0, 0, 0, 0, 0, 0, 0, 1) = LocalGroup
+      | (a, b, c, d, e, f) == (0, 0, 0, 0, 0, 0xffff) = v4 (word32 g h)
+      | not (isRoutable (SockAddrInet6 1 0 (tupleToHostAddress6 t) 0)) = UnroutableGroup
+      | (a, b, c, d, e, f) == (0x64, 0xff9b, 0, 0, 0, 0) = linked g h
+      | (a, b, c, d, e, f) == (0, 0, 0, 0, 0xffff, 0) = linked g h
+      | a == 0x2002 = linked b c
+      | (a, b) == (0x2001, 0) = linked (complement g) (complement h)
+      | (a, b) == (0x2001, 0x0470) = IPv6Group (bytes [a, b] <> [hi c .|. 0x0f])
+      | otherwise = IPv6Group (bytes [a, b])
+    linked g h = let (w, x, _, _) = word32 g h in IPv4Group w x
+    word32 :: Word16 -> Word16 -> (Word8, Word8, Word8, Word8)
+    word32 g h = (hi g, lo g, hi h, lo h)
+    bytes = concatMap (\w -> [hi w, lo w])
+    hi, lo :: Word16 -> Word8
+    hi w = fromIntegral (w `shiftR` 8)
+    lo w = fromIntegral (w .&. 0xff)
+
 -- | Whether an IPv4 address is public unicast.
 routable4 :: (Word8, Word8, Word8, Word8) -> Bool
 routable4 (a, b, c, _)
@@ -134,24 +202,46 @@
   | a >= 224 = False -- multicast and reserved
   | otherwise = True
 
+-- | Longest wait for a TCP connection to open: @DEFAULT_CONNECT_TIMEOUT@ in
+-- Bitcoin Core 32.1, 5 seconds.
+connectTimeout :: NominalDiffTime
+connectTimeout = 5
+
 -- | Open a TCP connection to a peer address and pass its conduits to a
 -- function. The connection is closed when the function returns. Calls 'error'
 -- if the address cannot be converted into a host and port.
+--
+-- Opening the connection fails with an 'IOException' after 'connectTimeout'.
+-- Without the limit, an address that drops connection requests held a slot
+-- of the peer manager until the operating system gave up, about two minutes
+-- on Linux. The peer manager cannot stop a connection that is still opening,
+-- because the peer process reads its mailbox only once the connection is
+-- open.
 withConnection :: SockAddr -> WithConnection
 withConnection sa f =
   fromSockAddr sa >>= \case
     Nothing -> error $ "Invalid address " <> show sa
-    Just settings ->
-      runTCPClient settings $ \ad ->
-        f Conduits {inboundConduit = appSource ad, outboundConduit = appSink ad}
+    Just (host, port) ->
+      timeout micros (getSocketFamilyTCP host port AF_UNSPEC) >>= \case
+        Nothing -> ioError (userError ("Connection to " <> show sa <> " timed out"))
+        Just (s, _) ->
+          f Conduits {inboundConduit = source s, outboundConduit = sinkSocket s}
+            `finally` close s
+  where
+    micros = floor (connectTimeout * 1000000)
+    -- Pieces of the size that the TCP client of streaming-commons reads.
+    size = getReadBufferSize (clientSettingsTCP 0 "")
+    source s = do
+      bs <- liftIO (recv s size)
+      unless (B.null bs) (yield bs >> source s)
 
--- | Turn a socket address into client settings for a TCP connection, or
--- 'Nothing' if it cannot be converted.
-fromSockAddr :: SockAddr -> IO (Maybe ClientSettings)
+-- | Turn a socket address into a numeric host and a port, or 'Nothing' if it
+-- cannot be converted.
+fromSockAddr :: SockAddr -> IO (Maybe (ByteString, Int))
 fromSockAddr sa =
   resolve `catch` \(_ :: IOException) -> return Nothing
   where
     flags = [NI_NUMERICHOST, NI_NUMERICSERV]
     resolve = do
-      (host, port) <- (getNameInfo flags True True sa)
-      return $ clientSettings <$> (readMaybe =<< port) <*> (cs <$> host)
+      (host, port) <- getNameInfo flags True True sa
+      return $ (,) <$> (cs <$> host) <*> (readMaybe =<< port)
diff --git a/src/Haskoin/Node/Block.hs b/src/Haskoin/Node/Block.hs
new file mode 100644
--- /dev/null
+++ b/src/Haskoin/Node/Block.hs
@@ -0,0 +1,223 @@
+-- |
+-- Module      : Haskoin.Node.Block
+-- Copyright   : (c) Haskoin Developers
+-- License     : MIT
+-- Maintainer  : jprupp@protonmail.ch
+-- Stability   : experimental
+-- Portability : POSIX
+--
+-- Whether the transactions of a block are the ones its header commits to.
+--
+-- A block on the wire is a header and a list of transactions. The proof of
+-- work covers the header only. The header commits to the transactions
+-- through its Merkle root, and since SegWit the coinbase commits to their
+-- witness data. A peer can send a real header, with real proof of work,
+-- together with transactions of its choice. Nothing else stops it.
+--
+-- 'blockMutation' is the check that catches this. It is a port of
+-- @IsBlockMutated@ in Bitcoin Core 32.1 (@src/validation.cpp@), which Core
+-- runs on every block a peer sends before it does anything else with it. A
+-- block that fails it is called mutated.
+--
+-- = Why it works this way
+--
+-- * __The same check as Bitcoin Core.__ The rules, their order and the
+--   reasons are those of @CheckMerkleRoot@, @IsBlockMutated@ and
+--   @CheckWitnessMalleation@. A stricter check would refuse valid blocks
+--   that some peer serves. A laxer one would let a peer change what a block
+--   holds without changing its hash.
+--
+-- * __Not block validation.__ The check says nothing about whether the
+--   transactions are valid, spend existing coins, or pay the right subsidy.
+--   It only says that the block is the one the header names. A node that
+--   needs more must validate blocks itself.
+--
+-- * __The header stays good.__ A mutated block does not make its header
+--   invalid. The same header with the right transactions is still a valid
+--   block (CVE-2012-2459). The node blames the peer that sent the mutated
+--   block and leaves the header chain alone.
+--
+-- * __SegWit depends on the height.__ Core checks the witness commitment
+--   only for a block at or above the SegWit activation height of the
+--   network. Before it, miners already put commitments in coinbases without
+--   the matching witness data, and those blocks are valid. So the witness
+--   rule needs the height of the parent block, which 'witnessCheck' turns
+--   into a 'WitnessCheck'. When the parent is not known, Core does not check
+--   the witness either, and neither does this module.
+module Haskoin.Node.Block
+  ( BlockMutation (..),
+    WitnessCheck (..),
+    blockMutation,
+    witnessCheck,
+    segWitHeight,
+  )
+where
+
+import Data.ByteString (ByteString)
+import Data.ByteString qualified as B
+import Data.Serialize (encode)
+import Haskoin
+
+-- | Why a block is not the one its header commits to. The names follow the
+-- reasons that Bitcoin Core 32.1 gives.
+data BlockMutation
+  = -- | the transactions do not hash to the Merkle root of the header, or
+    -- there are none (@bad-txnmrklroot@)
+    BadMerkleRoot
+  | -- | the Merkle tree hashes two identical nodes together, so the list of
+    -- transactions repeats some to keep the root (@bad-txns-duplicate@,
+    -- CVE-2012-2459)
+    DuplicateTransactions
+  | -- | the first transaction is not a coinbase and some transaction is 64
+    -- bytes long without its witness, so it may be an inner node of the
+    -- Merkle tree posing as a transaction
+    SixtyFourByteTransaction
+  | -- | the coinbase commits to witness data, but its witness is not a single
+    -- item of 32 bytes (@bad-witness-nonce-size@)
+    BadWitnessNonceSize
+  | -- | the witness data does not hash to the commitment in the coinbase
+    -- (@bad-witness-merkle-match@)
+    BadWitnessCommitment
+  | -- | a transaction carries witness data, but the block does not commit to
+    -- any (@unexpected-witness@)
+    UnexpectedWitness
+  deriving stock (Eq, Show)
+
+-- | Which witness rule applies to a block.
+data WitnessCheck
+  = -- | SegWit is active for the block. If the coinbase has a witness
+    -- commitment, the witness data must match it. If not, no transaction may
+    -- have witness data.
+    SegWitActive
+  | -- | SegWit is not active for the block, or the network has no SegWit. No
+    -- transaction may have witness data.
+    SegWitInactive
+  | -- | The height of the block is not known, so its witness data is not
+    -- checked. Its Merkle root still is.
+    WitnessUnknown
+  deriving stock (Eq, Show)
+
+-- | Height of the first block whose witness data is checked, on networks
+-- with SegWit. The values are @consensus.SegwitHeight@ in the chain
+-- parameters of Bitcoin Core 32.1 (@src/kernel/chainparams.cpp@). Networks
+-- without SegWit, and networks this module does not know, give 'Nothing'.
+segWitHeight :: Network -> Maybe BlockHeight
+segWitHeight net
+  | not net.segWit = Nothing
+  | otherwise = case net.name of
+      "btc" -> Just 481824
+      "btctest" -> Just 834624
+      "btctest4" -> Just 1
+      "btcreg" -> Just 0
+      _ -> Nothing
+
+-- | The witness rule for a block, given the header of its parent if the node
+-- has it. This is @DeploymentActiveAfter(prev_block, DEPLOYMENT_SEGWIT)@ in
+-- Bitcoin Core: SegWit is active when the height of the block, one more than
+-- its parent's, is at least 'segWitHeight'.
+witnessCheck :: Network -> Maybe BlockNode -> WitnessCheck
+witnessCheck net parent
+  | not net.segWit = SegWitInactive
+  | otherwise = case (parent, segWitHeight net) of
+      (Just p, Just h)
+        | p.height + 1 >= h -> SegWitActive
+        | otherwise -> SegWitInactive
+      _ -> WitnessUnknown
+
+-- | Why a block is not the one its header commits to, or 'Nothing' if it is.
+--
+-- The checks come in the order of @IsBlockMutated@ in Bitcoin Core 32.1:
+--
+-- 1. The transaction ids hash to the Merkle root of the header
+--    ('BadMerkleRoot'), and no level of the tree hashes two identical nodes
+--    together ('DuplicateTransactions').
+--
+-- 2. If the first transaction is not a coinbase, no transaction is 64 bytes
+--    long without its witness ('SixtyFourByteTransaction'). Such a block is
+--    invalid anyway, and the witness is not looked at.
+--
+-- 3. The witness rule that 'WitnessCheck' names.
+--
+-- A block without transactions has no Merkle root and fails the first
+-- check. Bitcoin Core refuses it as @bad-blk-length@.
+blockMutation :: WitnessCheck -> Block -> Maybe BlockMutation
+blockMutation rule b = case b.txs of
+  [] -> Just BadMerkleRoot
+  first : rest
+    | root /= Just b.header.merkle -> Just BadMerkleRoot
+    | mutated -> Just DuplicateTransactions
+    | not (isCoinbase first) ->
+        if any ((== 64) . strippedSize) b.txs
+          then Just SixtyFourByteTransaction
+          else Nothing
+    | otherwise -> witnessMutation rule first rest
+  where
+    txids = map txHash b.txs
+    -- haskoin-core gives the root of a tree that is not mutated, and refuses
+    -- to build a mutated one. Only then is the root built a second time, to
+    -- tell a wrong root from a mutated tree, in Bitcoin Core's order.
+    (root, mutated) = case buildMerkleRoot txids of
+      Right r -> (Just r, False)
+      Left _ -> (merkleRoot txids, True)
+
+-- | The witness part of the check, @CheckWitnessMalleation@ in Bitcoin Core,
+-- given the coinbase and the other transactions of the block.
+witnessMutation :: WitnessCheck -> Tx -> [Tx] -> Maybe BlockMutation
+witnessMutation rule coinbase rest = case rule of
+  WitnessUnknown -> Nothing
+  SegWitInactive -> noWitness
+  SegWitActive -> case witnessCommitment coinbase of
+    Nothing -> noWitness
+    Just commitment -> case coinbaseStack of
+      [reserved]
+        | B.length reserved == 32 ->
+            if committed reserved == Just commitment
+              then Nothing
+              else Just BadWitnessCommitment
+      _ -> Just BadWitnessNonceSize
+  where
+    noWitness
+      | any hasWitness (coinbase : rest) = Just UnexpectedWitness
+      | otherwise = Nothing
+    -- The witness stack of the only input of the coinbase.
+    coinbaseStack = case coinbase.witness of
+      stack : _ -> stack
+      [] -> []
+    -- The witness id of the coinbase counts as zero.
+    zero = "0000000000000000000000000000000000000000000000000000000000000000"
+    witnessRoot = merkleRoot (zero : map txWitnessHash rest)
+    committed reserved = do
+      root <- witnessRoot
+      return (encode (doubleSHA256 (encode root <> reserved)))
+
+-- | The 32 bytes of the last witness commitment among the outputs of a
+-- coinbase, as @GetWitnessCommitmentIndex@ in Bitcoin Core finds it: an
+-- output script of at least 38 bytes that starts with @OP_RETURN@, a push of
+-- 36 bytes, and the tag @aa21a9ed@.
+witnessCommitment :: Tx -> Maybe ByteString
+witnessCommitment tx =
+  case filter isCommitment (map (.script) tx.outputs) of
+    [] -> Nothing
+    scripts -> Just (B.take 32 (B.drop 6 (last scripts)))
+  where
+    isCommitment s =
+      B.length s >= 38 && B.take 6 s == B.pack [0x6a, 0x24, 0xaa, 0x21, 0xa9, 0xed]
+
+-- | The root of the Merkle tree over the given leaves, whether or not the
+-- tree is mutated, as @ComputeMerkleRoot@ in Bitcoin Core computes it.
+-- 'Nothing' for no leaves.
+merkleRoot :: [TxHash] -> Maybe Hash256
+merkleRoot leaves = calcHash (calcTreeHeight (length leaves)) 0 leaves
+
+-- | Whether a transaction is a coinbase, as @IsCoinBase@ in Bitcoin Core
+-- tells: it has one input, and that input spends the null outpoint.
+isCoinbase :: Tx -> Bool
+isCoinbase tx = case tx.inputs of
+  [i] -> i.outpoint == OutPoint {hash = zeroTx, index = 0xffffffff}
+  _ -> False
+  where
+    zeroTx = "0000000000000000000000000000000000000000000000000000000000000000"
+
+-- | Size of a transaction serialized without its witness.
+strippedSize :: Tx -> Int
+strippedSize tx = B.length (encode tx {witness = []})
diff --git a/src/Haskoin/Node/Chain.hs b/src/Haskoin/Node/Chain.hs
--- a/src/Haskoin/Node/Chain.hs
+++ b/src/Haskoin/Node/Chain.hs
@@ -30,18 +30,37 @@
 --   to show a better chain. "Haskoin.Node.Chain.Sync" decides whose turn it
 --   is.
 --
+-- * __A turn cannot be held forever.__ A turn ends when the peer sends a
+--   short batch, or a full batch that brings no header the node did not
+--   have, as a peer that replays known headers does. It also ends, with the
+--   peer dropped, when it passes the deadline that Bitcoin Core gives its
+--   initial headers sync and another peer could take over (see
+--   'syncDeadline'). Without these, one peer that kept sending full batches
+--   held the turn until it disconnected, and no other peer was asked.
+--
 -- * __Every hint of unknown blocks is followed.__ A peer announces a new block
 --   with a headers message only while it believes the node has the parent.
 --   When many blocks are found at once, or the node missed an announcement,
 --   the peer sends an inventory message instead, or headers that do not
---   connect. Either way the node asks that peer for headers. Ignoring these
+--   connect. Either way the node asks that peer for headers: at once if
+--   another peer holds the turn, as Bitcoin Core does, with at most one
+--   request in flight per peer, and again when its turn comes. Ignoring these
 --   left the chain stuck at an old height until the peer reconnected.
 --
 -- * __Quiet means poll.__ If no headers are requested or received for
 --   'timeout' seconds, every connected peer is asked for headers again. This
---   costs one small request per peer per quiet period, and puts a bound on how
---   long any unforeseen stall can last.
+--   costs one small request per peer per quiet period, and ends a stall in
+--   which nothing happens at all. A stall in which a peer keeps sending
+--   headers is not quiet; the rules above end that one.
 --
+-- * __Headers are kept before the chain has the minimum work.__ Bitcoin Core
+--   first checks that a peer's headers reach the network's minimum chain
+--   work and only then stores them (its @HeadersSyncState@). This node
+--   stores every valid header at once. During the initial sync, a peer can
+--   therefore make the node store a fork of low difficulty, at the cost of
+--   its proof of work. The deadline above bounds how long one turn can do
+--   this, but not the disk used over many turns.
+--
 -- * __Most work wins.__ The best chain is the one with the most accumulated
 --   proof of work, not the longest or the first seen, as in every Bitcoin
 --   implementation.
@@ -82,7 +101,8 @@
 import Control.Monad (filterM, unless, void, when)
 import Data.Function (on)
 import Data.Functor ((<&>))
-import Data.Maybe (isNothing)
+import Data.List.NonEmpty qualified as NE
+import Data.Maybe (isJust, isNothing)
 import Data.String.Conversions (cs)
 import Data.Text (Text)
 import Data.Time.Clock
@@ -257,9 +277,10 @@
 processHeaders :: Chain -> Peer -> [BlockHeader] -> IO ()
 processHeaders ch p [] = do
   logDebug ch.config.logger ("No headers from peer " <> p.label)
+  update ch (gotHeaders p)
   syncing <- isSyncing ch p
   when syncing $ finish ch p
-processHeaders ch p hs@(h : _) = do
+processHeaders ch p hs@(h : rest) = do
   logDebug
     ch.config.logger
     ("Processing " <> cs (show (length hs)) <> " headers from peer " <> p.label)
@@ -270,13 +291,21 @@
         ("Headers from peer " <> p.label <> " do not connect")
       update ch (requestSync p)
       syncNext ch
-    Just _ ->
+      askAnnouncer ch p
+    Just _ -> do
+      update ch (gotHeaders p)
+      -- Stored headers form a tree from genesis, so the batch brings nothing
+      -- new exactly when its last header is stored already.
+      known <- isJust <$> chainGetBlock ch (headerHash (NE.last (h NE.:| rest)))
       importHeaders ch hs >>= \case
         Left e -> misbehaving ch p ("could not connect headers: " <> cs e)
         Right lst -> do
           syncing <- isSyncing ch p
           let full = length hs >= fromIntegral maxHeadersSize
           if
+            | full && syncing && known -> do
+                logDebug ch.config.logger ("No new headers from peer " <> p.label)
+                finish ch p
             | full && syncing -> requestHeaders ch p (Just lst)
             | full -> update ch (requestSync p) >> syncNext ch
             | syncing -> finish ch p
@@ -298,8 +327,24 @@
       )
     update ch (requestSync p)
     syncNext ch
+    askAnnouncer ch p
 
--- | Disconnect the syncing peer if it has not answered in time. If no peer is
+-- | Ask a peer for headers at once, because it told the node about blocks
+-- the node does not have, unless it is the syncing peer, whose request is
+-- outstanding, or a request to it is in flight already (see 'mayAsk'). The
+-- peer stays queued for its turn as well.
+askAnnouncer :: Chain -> Peer -> IO ()
+askAnnouncer ch p = do
+  now <- getCurrentTime
+  s <- (.sync) <$> readTVarIO ch.state
+  let syncing = fmap fst (syncingPeer s) == Just p
+  when (not syncing && mayAsk now p s) $ do
+    best <- withDB ch getBestBlockHeader
+    logDebug ch.config.logger ("Asking announcing peer for headers: " <> p.label)
+    sendGetHeaders ch now p best
+
+-- | Disconnect the syncing peer if it has not answered in time, or if its
+-- turn is past its deadline and another peer can take over. If no peer is
 -- syncing, start with a queued one, or queue every peer if nothing has
 -- happened for a while.
 checkSync :: Chain -> IO ()
@@ -310,6 +355,7 @@
   case syncingPeer s of
     Just (p, t)
       | quiet t -> misbehaving ch p "timed out"
+      | syncTimedOut now s -> misbehaving ch p "headers sync took too long"
       | otherwise -> return ()
     Nothing
       | not (null (queuedPeers s)) -> syncNext ch
@@ -333,7 +379,8 @@
         True -> do
           logDebug ch.config.logger ("Syncing against peer " <> p.label)
           now <- getCurrentTime
-          update ch (startSync now p)
+          best <- withDB ch getBestBlockHeader
+          update ch (startSync now (syncDeadline ch.config.net now best) p)
           requestHeaders ch p Nothing
         False -> do
           logDebug ch.config.logger ("Could not lock peer: " <> p.label)
@@ -346,6 +393,13 @@
   now <- getCurrentTime
   update ch (refreshSync now p)
   bn <- maybe (withDB ch getBestBlockHeader) return after
+  sendGetHeaders ch now p bn
+
+-- | Send a peer a request for the headers after the given block, and record
+-- it as in flight.
+sendGetHeaders :: Chain -> UTCTime -> Peer -> BlockNode -> IO ()
+sendGetHeaders ch now p bn = do
+  update ch (askHeaders now p)
   loc <- withDB ch (blockLocator bn)
   logDebug
     ch.config.logger
@@ -400,22 +454,27 @@
 
 -- | Validate and store a run of headers, and publish the best block if it
 -- changed. Returns the node of the last header.
+--
+-- The best block is compared even when a header fails. haskoin-core's
+-- 'connectBlocks' keeps the headers before the one that failed, and they may
+-- have moved the best block.
 importHeaders ::
   Chain -> [BlockHeader] -> IO (Either String BlockNode)
 importHeaders ch hs = do
   now <- getCurrentTime
   let timestamp = floor (utcTimeToPOSIXSeconds now)
   before <- withDB ch getBestBlockHeader
-  withDB ch (connectBlocks ch.config.net timestamp hs) >>= \case
+  result <- withDB ch (connectBlocks ch.config.net timestamp hs)
+  after <- withDB ch getBestBlockHeader
+  when (before.header /= after.header) $
+    chainEvent ch (ChainBestBlock after)
+  case result of
     Left e -> do
       logError ch.config.logger ("connectBlocks: " <> cs e)
       return (Left e)
     Right [] -> return (Left "no headers")
     Right (lst : _) -> do
       update ch (touchSync now)
-      after <- withDB ch getBestBlockHeader
-      when (before.header /= after.header) $
-        chainEvent ch (ChainBestBlock after)
       return (Right lst)
 
 -- | Publish a 'ChainSynced' event the first time the chain is synced (see
diff --git a/src/Haskoin/Node/Chain/Sync.hs b/src/Haskoin/Node/Chain/Sync.hs
--- a/src/Haskoin/Node/Chain/Sync.hs
+++ b/src/Haskoin/Node/Chain/Sync.hs
@@ -32,6 +32,26 @@
 --   out is marked 'Dropped' until its disconnection arrives, so nothing can
 --   queue it in between.
 --
+-- * __A turn has a deadline.__ A peer that keeps sending full batches never
+--   finishes its turn, and while it holds the turn nobody else is asked. So
+--   each turn gets the deadline that Bitcoin Core gives its initial headers
+--   sync, 15 minutes plus 1 millisecond for each header expected from the age
+--   of the best block ('syncDeadline'). When it passes and another peer could
+--   take over, the turn ends with the peer dropped ('syncTimedOut'). Core
+--   applies the deadline only while the best block is more than a day old.
+--   Here it applies to every turn, because the chain only counts as synced
+--   once no peer holds a turn, so a peer that held one forever would keep it
+--   from ever being synced. An honest turn after the initial sync takes
+--   seconds.
+--
+-- * __Announcements get an answer at once.__ A peer that announces an
+--   unknown block while another peer holds the turn is asked for headers
+--   directly, as Bitcoin Core does, so that a slow or hostile syncing peer
+--   cannot keep the node from hearing about new blocks. At most one such
+--   request is in flight per peer ('mayAsk'): a request counts as answered
+--   when the peer sends headers that connect, or none, and expires after
+--   'headersResponseTime'.
+--
 -- * __Pure and polymorphic.__ The rules are plain functions on a value, over
 --   any peer type with equality, so they can be tested exhaustively with
 --   integers instead of network connections. Transitions that do not apply to
@@ -45,11 +65,19 @@
     peerDisconnected,
     requestSync,
     startSync,
+    syncDeadline,
+    syncTimedOut,
     refreshSync,
     finishSync,
     dropPeer,
     pollPeers,
     touchSync,
+    askHeaders,
+    gotHeaders,
+    mayAsk,
+    headersResponseTime,
+    headersSyncTimeoutBase,
+    headersSyncTimeoutPerHeader,
     peerStatus,
     syncingPeer,
     queuedPeers,
@@ -61,7 +89,7 @@
 where
 
 import Data.Maybe (isNothing, listToMaybe)
-import Data.Time.Clock (NominalDiffTime, UTCTime, diffUTCTime)
+import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, diffUTCTime)
 import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
 import Haskoin (BlockHeader (..), BlockNode (..), Network (..))
 
@@ -80,16 +108,21 @@
   deriving stock (Eq, Show)
 
 -- | Connected peers in queue order, with the last time that headers were
--- requested or received.
+-- requested or received, the deadline of the current turn, and the requests
+-- for headers in flight.
 data SyncState p = SyncState
   { peers :: ![(p, PeerStatus)],
-    activity :: !UTCTime
+    activity :: !UTCTime,
+    -- | when the turn of the syncing peer must end; set by 'startSync'
+    deadline :: !(Maybe UTCTime),
+    -- | peers asked for headers that have not answered, with the time asked
+    asked :: ![(p, UTCTime)]
   }
   deriving stock (Eq, Show)
 
 -- | No peers, with the given time as the last activity.
 emptySync :: UTCTime -> SyncState p
-emptySync = SyncState []
+emptySync t = SyncState {peers = [], activity = t, deadline = Nothing, asked = []}
 
 -- | A peer completed the handshake. It is queued to be asked for headers.
 peerConnected :: (Eq p) => p -> SyncState p -> SyncState p
@@ -99,7 +132,8 @@
 
 -- | A peer disconnected.
 peerDisconnected :: (Eq p) => p -> SyncState p -> SyncState p
-peerDisconnected p s = s {peers = filter ((/= p) . fst) s.peers}
+peerDisconnected p s =
+  s {peers = filter ((/= p) . fst) s.peers, asked = filter ((/= p) . fst) s.asked}
 
 -- | The peer told the node about blocks that it does not have.
 requestSync :: (Eq p) => p -> SyncState p -> SyncState p
@@ -109,14 +143,49 @@
     Just (Syncing t _) -> setStatus p (Syncing t True) s
     _ -> s
 
--- | Start asking a queued peer for headers, unless another peer is being
--- asked already.
-startSync :: (Eq p) => UTCTime -> p -> SyncState p -> SyncState p
-startSync now p s =
+-- | Start asking a queued peer for headers at the given time, unless another
+-- peer is being asked already. The second time is the deadline of the turn
+-- (see 'syncDeadline').
+startSync :: (Eq p) => UTCTime -> UTCTime -> p -> SyncState p -> SyncState p
+startSync now end p s =
   case (syncingPeer s, peerStatus p s) of
-    (Nothing, Just Queued) -> setStatus p (Syncing now False) s {activity = now}
+    (Nothing, Just Queued) ->
+      setStatus p (Syncing now False) s {activity = now, deadline = Just end}
     _ -> s
 
+-- | Base of the deadline of a turn: @HEADERS_DOWNLOAD_TIMEOUT_BASE@ in
+-- Bitcoin Core 32.1, 15 minutes.
+headersSyncTimeoutBase :: NominalDiffTime
+headersSyncTimeoutBase = 15 * 60
+
+-- | Time added to the deadline of a turn for each header expected:
+-- @HEADERS_DOWNLOAD_TIMEOUT_PER_HEADER@ in Bitcoin Core 32.1, 1 millisecond.
+headersSyncTimeoutPerHeader :: NominalDiffTime
+headersSyncTimeoutPerHeader = 0.001
+
+-- | Deadline of a turn that starts at the given time with the given best
+-- block, as Bitcoin Core sets it for its initial headers sync:
+-- 'headersSyncTimeoutBase', plus 'headersSyncTimeoutPerHeader' for each
+-- block that should have been found since the best block, one every
+-- 'targetSpacing' of the network.
+syncDeadline :: Network -> UTCTime -> BlockNode -> UTCTime
+syncDeadline net now best = timeout `addUTCTime` now
+  where
+    tipTime = posixSecondsToUTCTime (fromIntegral best.header.timestamp)
+    age = max 0 (floor (now `diffUTCTime` tipTime)) :: Integer
+    expected = age `div` max 1 (fromIntegral net.targetSpacing)
+    timeout = headersSyncTimeoutBase + fromIntegral expected * headersSyncTimeoutPerHeader
+
+-- | Whether the turn of the syncing peer has passed its deadline while
+-- another connected peer could take over. Bitcoin Core only drops its
+-- initial sync peer when it has another one to use.
+syncTimedOut :: (Eq p) => UTCTime -> SyncState p -> Bool
+syncTimedOut now s =
+  case (syncingPeer s, s.deadline) of
+    (Just (p, _), Just end) ->
+      now > end && any (/= p) (connectedPeers s)
+    _ -> False
+
 -- | Another request was sent to the peer being synced against.
 refreshSync :: (Eq p) => UTCTime -> p -> SyncState p -> SyncState p
 refreshSync now p s =
@@ -142,7 +211,7 @@
 -- | Queue every idle peer, and record the time as activity so that polling
 -- happens at most once per quiet period.
 pollPeers :: UTCTime -> SyncState p -> SyncState p
-pollPeers now s = SyncState {peers = map poll s.peers, activity = now}
+pollPeers now s = s {peers = map poll s.peers, activity = now}
   where
     poll (p, Idle) = (p, Queued)
     poll x = x
@@ -150,6 +219,30 @@
 -- | Headers were received at the given time.
 touchSync :: UTCTime -> SyncState p -> SyncState p
 touchSync now s = s {activity = now}
+
+-- | Longest that a request for headers counts as in flight:
+-- @HEADERS_RESPONSE_TIME@ in Bitcoin Core 32.1, 2 minutes.
+headersResponseTime :: NominalDiffTime
+headersResponseTime = 120
+
+-- | A request for headers was sent to the peer at the given time.
+askHeaders :: (Eq p) => UTCTime -> p -> SyncState p -> SyncState p
+askHeaders now p s = s {asked = (p, now) : filter ((/= p) . fst) s.asked}
+
+-- | The peer sent headers that answer a request: headers that connect to
+-- the chain, or none. Headers that do not connect cannot be an answer, as
+-- Bitcoin Core reasons, so they leave the request in flight.
+gotHeaders :: (Eq p) => p -> SyncState p -> SyncState p
+gotHeaders p s = s {asked = filter ((/= p) . fst) s.asked}
+
+-- | Whether the peer may be asked for headers at the given time: no request
+-- to it is in flight, or the last one is older than 'headersResponseTime'.
+-- This is the rule of @MaybeSendGetHeaders@ in Bitcoin Core.
+mayAsk :: (Eq p) => UTCTime -> p -> SyncState p -> Bool
+mayAsk now p s =
+  case lookup p s.asked of
+    Nothing -> True
+    Just t -> now `diffUTCTime` t > headersResponseTime
 
 -- | Status of a peer, or 'Nothing' if it is not connected.
 peerStatus :: (Eq p) => p -> SyncState p -> Maybe PeerStatus
diff --git a/src/Haskoin/Node/Peer.hs b/src/Haskoin/Node/Peer.hs
--- a/src/Haskoin/Node/Peer.hs
+++ b/src/Haskoin/Node/Peer.hs
@@ -24,10 +24,23 @@
 --   the payload read, so a peer cannot make the node buffer a huge message it
 --   would refuse anyway.
 --
+-- * A payload is read in time and memory linear in its size, however small
+--   the pieces it arrives in. The pieces are collected and joined once. An
+--   earlier version appended each piece to the bytes read so far, so a peer
+--   that sent a large message in small TCP segments made the node copy it
+--   over and over, with a cost that grew with the square of the size.
+--
 -- * Anything that does not parse closes the connection with a
 --   'PeerException' saying why. There is no attempt to recover, because a
 --   peer that sends garbage once is not worth the risk.
 --
+-- * A block whose transactions are not the ones its header commits to closes
+--   the connection too ('MutatedBlock'). The header carries the proof of
+--   work, but anyone can attach other transactions to it. The check is
+--   "Haskoin.Node.Block", the same as Bitcoin Core runs on every block it
+--   receives. It is done here, once, so that 'getBlocks', 'getData' and the
+--   'PeerMessage' events all see only blocks that passed it.
+--
 -- * Reading pauses when the node falls behind ('maxPendingMessages'), so the
 --   speed of the node, not the speed of the peer, sets the pace.
 module Haskoin.Node.Peer
@@ -75,6 +88,7 @@
 import Data.Text (Text)
 import Data.Word (Word32)
 import Haskoin
+import Haskoin.Node.Block
 import Haskoin.Node.Logger
 import Haskoin.Node.Loop (loopForever)
 import Haskoin.Node.Peer.Lock
@@ -109,7 +123,14 @@
     -- | how to open the connection to the peer
     connect :: !WithConnection,
     -- | log messages here
-    logger :: !Logger
+    logger :: !Logger,
+    -- | look up a block header that the node has stored, or give 'Nothing'.
+    -- A block from the peer is checked against its parent's height, to know
+    -- whether its witness data must match the commitment in its coinbase
+    -- (see 'witnessCheck'). "Haskoin.Node" passes 'Haskoin.Node.chainGetBlock'.
+    -- A function that always gives 'Nothing' still checks the Merkle root of
+    -- every block, but not its witness data.
+    lookupBlock :: !(BlockHash -> IO (Maybe BlockNode))
   }
 
 -- | Events published about peers.
@@ -118,7 +139,11 @@
     PeerConnected !Peer
   | -- | the peer disconnected
     PeerDisconnected !Peer
-  | -- | the peer sent a message
+  | -- | the peer sent a message. A block in an 'MBlock' message has passed
+    -- 'blockMutation': its transactions hash to the Merkle root of its
+    -- header, and its witness data matches its coinbase when the node knows
+    -- the parent of the block. Nothing else about it is checked. A
+    -- transaction in an 'MTx' message is not checked at all.
     PeerMessage !Peer !Message
   deriving (Eq)
 
@@ -138,6 +163,9 @@
     MessageTooLarge !MessageCommand !Word32
   | -- | the payload could not be parsed; holds the reason
     InvalidPayload !MessageCommand !String
+  | -- | a block whose transactions are not the ones its header commits to;
+    -- holds the hash of the block and the reason (see 'blockMutation')
+    MutatedBlock !BlockHash !BlockMutation
   deriving stock (Show)
 
 instance Exception PeerException
@@ -263,29 +291,46 @@
 -- The counts of list messages are not checked here. 'getMessage' fails as
 -- soon as it reads a count above the limit of the message. The limits are
 -- 2000 headers and 1000 addresses, for example.
+--
+-- The bytes of a message are collected as the pieces that arrive, and joined
+-- once, header and payload together. The cost of reading is linear in the
+-- size of the message, whatever the size of the pieces.
+--
+-- A block must pass 'blockMutation' before it is passed on. Its parent is
+-- looked up with 'lookupBlock' to choose the witness rule.
 inPeerConduit ::
   PeerConfig -> ConduitT ByteString Message IO ()
-inPeerConduit PeerConfig {label, net, logger} = loopForever $ do
+inPeerConduit PeerConfig {label, net, logger, lookupBlock} = loopForever $ do
   debug (label <> " awaiting message...")
-  x <- takeExactly 24
+  hdr <- takePieces 24
+  let x = B.concat hdr
   MessageHeader mgc cmd len _ <- case decode x of
     Left _ -> bad InvalidMessageHeader
     Right h -> return h
   when (mgc /= net.magic) $ bad (WrongNetwork mgc)
   when (len > maxPayloadSize net cmd) $ bad (MessageTooLarge cmd len)
   debug (label <> " sent cmd " <> cs (show cmd))
-  y <- takeExactly (fromIntegral len)
-  case runGet (getMessage net) $ x `B.append` y of
+  payload <- takePieces (fromIntegral len)
+  case runGet (getMessage net) (B.concat (x : payload)) of
     Left e -> bad (InvalidPayload cmd (firstLine e))
     Right m -> do
       debug (label <> " sent payload for cmd " <> cs (show cmd))
+      checkBlock m
       yield m
   where
     debug = liftIO . logDebug logger
-    takeExactly n = do
-      bs <- takeCE n .| foldC
-      when (B.length bs /= n) $ bad ConnectionClosed
-      return bs
+    -- Exactly n bytes, as the pieces they arrived in. Joining them is left
+    -- to the caller, so that it happens once.
+    takePieces n = do
+      pieces <- takeCE n .| sinkList
+      when (sum (map B.length pieces) /= n) $ bad ConnectionClosed
+      return pieces
+    checkBlock = \case
+      MBlock b -> do
+        parent <- liftIO (lookupBlock b.header.prev)
+        forM_ (blockMutation (witnessCheck net parent) b) $
+          bad . MutatedBlock (headerHash b.header)
+      _ -> return ()
     bad :: PeerException -> ConduitT i o IO a
     bad e = liftIO $ do
       logError logger (label <> ": " <> cs (show e))
@@ -356,6 +401,13 @@
 --
 -- The 'Int' argument is the timeout in seconds. On networks with SegWit,
 -- blocks are requested with their witness data.
+--
+-- Every block returned has passed 'blockMutation': its transactions hash to
+-- the Merkle root of its header, and, when the node knows its parent, its
+-- witness data matches the commitment in its coinbase. A peer that sends a
+-- block that fails is disconnected, and the request then gives 'Nothing'
+-- when it times out. The blocks are not validated otherwise: their
+-- transactions may still be invalid.
 getBlocks ::
   Network ->
   Int ->
@@ -377,6 +429,11 @@
 --
 -- The 'Int' argument is the timeout in seconds. Peers normally only serve
 -- transactions that are in their mempool.
+--
+-- A transaction is matched by its id, which does not cover its witness. The
+-- peer can return the right transaction with any witness data, and nothing
+-- here can tell. Treat the witness of a transaction from 'getTxs', or from an
+-- 'MTx' event, as unauthenticated until the transaction is found in a block.
 getTxs ::
   Network ->
   Int ->
@@ -401,7 +458,8 @@
 -- items means that the peer will not send the rest. Unrelated messages that
 -- arrive meanwhile are ignored. Transactions are returned as 'Left' and blocks
 -- as 'Right', in the order they were requested. "Haskoin.Node.Peer.Request"
--- has the rules.
+-- has the rules. Blocks are checked as 'getBlocks' says, and transactions as
+-- 'getTxs' says.
 getData ::
   Int -> Peer -> GetData -> IO (Maybe [Either Tx Block])
 getData seconds p gd@(GetData ivs) =
diff --git a/src/Haskoin/Node/Peer/Request.hs b/src/Haskoin/Node/Peer/Request.hs
--- a/src/Haskoin/Node/Peer/Request.hs
+++ b/src/Haskoin/Node/Peer/Request.hs
@@ -30,6 +30,12 @@
 --
 -- Keeping these rules in a pure function means each one can be tested on its
 -- own, without a connection.
+--
+-- A block is matched to a request by the hash of its header only. That is
+-- enough because the peer process checks every block before passing it on,
+-- with 'Haskoin.Node.Block.blockMutation': a block that arrives here holds
+-- the transactions its header commits to. A transaction is matched by its
+-- id, which does not cover its witness.
 module Haskoin.Node.Peer.Request
   ( Request,
     RequestStep (..),
diff --git a/src/Haskoin/Node/PeerMgr.hs b/src/Haskoin/Node/PeerMgr.hs
--- a/src/Haskoin/Node/PeerMgr.hs
+++ b/src/Haskoin/Node/PeerMgr.hs
@@ -63,8 +63,16 @@
 --
 -- * __Relayed addresses are untrusted.__ Peers gossip addresses, and a
 --   malicious peer could gossip private or loopback addresses to make the node
---   probe its own network. Only public addresses are accepted, and only a
---   bounded number are kept, so gossip cannot exhaust memory.
+--   probe its own network. Only public addresses are accepted, from gossip and
+--   from DNS seeds alike, and only a bounded number are kept, so gossip cannot
+--   exhaust memory.
+--
+-- * __One connection per network group.__ Addresses that the node learned are
+--   picked at random, and at most one connection is open to each network group
+--   (a /16 of IPv4, a /32 of IPv6; see 'Haskoin.Node.Address.netGroup'), as in
+--   Bitcoin Core. One operator with one block of addresses can then hold one
+--   slot, not all of them. Configured peers are exempt: the operator chose
+--   them.
 module Haskoin.Node.PeerMgr
   ( PeerMgrConfig (..),
     PeerEvent (..),
@@ -107,7 +115,7 @@
 import Data.Word (Word32, Word64)
 import GHC.Records (HasField (..))
 import Haskoin
-import Haskoin.Node.Address (isRoutable, toHostService, toSockAddr)
+import Haskoin.Node.Address (NetGroup, isRoutable, netGroup, toHostService, toSockAddr)
 import Haskoin.Node.Logger
 import Haskoin.Node.Loop (loopForever)
 import Haskoin.Node.Peer
@@ -143,7 +151,10 @@
     -- | how to open a connection to a peer address
     connect :: !(SockAddr -> WithConnection),
     -- | log messages here
-    logger :: !Logger
+    logger :: !Logger,
+    -- | look up a stored block header; given to every peer as the
+    -- @lookupBlock@ of its t'PeerConfig', to check the blocks it sends
+    lookupBlock :: !(BlockHash -> IO (Maybe BlockNode))
   }
 
 -- | Handle to a running peer manager. Obtain one with 'withPeerMgr', or from
@@ -298,7 +309,7 @@
   PeerVersion p v -> do
     logDebug mgr.config.logger ("Received version from peer " <> p.label)
     nonces <- map (.nonce) <$> readTVarIO mgr.peers
-    peerInput mgr p $ either Refused (GotHandshake . GotVersion) (checkVersion nonces v)
+    peerInput mgr p $ either Refused (GotHandshake . GotVersion) (checkVersion mgr.config.net nonces v)
   PeerVerAck p -> do
     logDebug mgr.config.logger ("Received version ack from peer " <> p.label)
     peerInput mgr p (GotHandshake GotVerAck)
@@ -437,37 +448,56 @@
 -- | Next address to connect to. The configured peers and, if discovery is on,
 -- the seeds are loaded when there is nothing to try and they were not loaded
 -- recently.
+--
+-- Configured peers come first. Otherwise an address is picked at random among
+-- those in a network group that the node is not connected to yet, as Bitcoin
+-- Core requires of its automatic outbound connections (see 'netGroup').
 getNewPeer :: PeerMgr -> IO (Maybe SockAddr)
 getNewPeer mgr = do
   now <- getCurrentTime
   reload <- needsReload now <$> readTVarIO mgr.addresses
   when reload $ loadPeers mgr now
-  atomically . stateTVar mgr.addresses $ \book ->
-    case takeAddress now book of
-      Just (sa, book') -> (Just sa, book')
-      Nothing -> (Nothing, book)
+  r <- randomIO
+  atomically $ do
+    used <- usedGroups <$> readTVar mgr.peers
+    stateTVar mgr.addresses $ \book ->
+      case takeAddress now r ((`notElem` used) . netGroup) book of
+        Just (sa, book') -> (Just sa, book')
+        Nothing -> (Nothing, book)
 
+-- | Network groups of the open connections.
+usedGroups :: [OnlinePeer] -> [NetGroup]
+usedGroups = map (netGroup . (.address))
+
 -- | Resolve the configured peers and, if discovery is on, the seeds of the
--- network, and add them to the address book.
+-- network, and add them to the address book. Seed results must be routable,
+-- like relayed addresses: whoever answers the DNS query could otherwise point
+-- the node at its own network. Bitcoin Core's address manager refuses them
+-- too. On regtest the seed is @localhost@, so local peers there have to be
+-- configured.
 loadPeers :: PeerMgr -> UTCTime -> IO ()
 loadPeers mgr now = do
   let net = mgr.config.net
       resolve = fmap concat . mapM (toSockAddr net)
   configured <- resolve mgr.config.peers
-  seeds <- if mgr.config.discover then resolve net.seeds else return []
+  seeds <- if mgr.config.discover then filter isRoutable <$> resolve net.seeds else return []
   atomically . modifyTVar' mgr.addresses $ \book ->
     markLoaded now $
-      foldr (addAddress Discovered) (foldr (addAddress Configured) book configured) seeds
+      foldr (addAddress Seeded) (foldr (addAddress Configured) book configured) seeds
 
 -- | Start a peer process for an address taken from the address book and send
--- it our version, unless there are no free slots or the address is connected
--- already, in which case the address is given back.
+-- it our version, unless there are no free slots, the address is connected
+-- already, or it is a seed or gossiped address in a network group that the
+-- node is connected to already. Then the address is given back.
 connectPeer :: PeerMgr -> SockAddr -> IO ()
 connectPeer mgr sa = do
   ops <- readTVarIO mgr.peers
+  source <- addressSource sa <$> readTVarIO mgr.addresses
   if
     | length ops >= mgr.config.maxPeers -> giveBack "no free slots"
     | any ((== sa) . (.address)) ops -> giveBack "already connected"
+    | source /= Just Configured && netGroup sa `elem` usedGroups ops ->
+        giveBack "network group in use"
     | otherwise -> do
         logInfo mgr.config.logger ("Connecting to peer " <> cs (show sa))
         nonce <- randomIO
@@ -484,7 +514,8 @@
                   net = net,
                   label = cs (show sa),
                   connect = mgr.config.connect sa,
-                  logger = withSource "Peer" mgr.config.logger
+                  logger = withSource "Peer" mgr.config.logger,
+                  lookupBlock = mgr.config.lookupBlock
                 }
         (inbox, mailbox) <- newMailbox
         busy <- newTVarIO Free
diff --git a/src/Haskoin/Node/PeerMgr/Addresses.hs b/src/Haskoin/Node/PeerMgr/Addresses.hs
--- a/src/Haskoin/Node/PeerMgr/Addresses.hs
+++ b/src/Haskoin/Node/PeerMgr/Addresses.hs
@@ -24,10 +24,28 @@
 -- * __Configured peers are trusted more.__ Addresses from the configuration
 --   are what the operator asked for, so they are never banned and never
 --   forgotten: they back off at most 'maxBackoff', even after misbehaving.
---   Discovered addresses, from DNS seeds and gossip, are banned for
---   misbehaving, and at most 'maxDiscovered' of them are kept, so gossip
---   cannot exhaust memory.
+--   They are also tried first. Addresses from DNS seeds and gossip are
+--   banned for misbehaving, and at most 'maxDiscovered' of each are kept, so
+--   gossip cannot exhaust memory.
 --
+-- * __Seeds and gossip are kept apart.__ Addresses from DNS seeds count
+--   against their own limit. A peer that gossips thousands of addresses can
+--   fill the room for gossip, but not crowd out the seeds. Before, both
+--   shared one limit, and once gossip had filled it, no new seed address was
+--   learned.
+--
+-- * __A full book still learns.__ When the limit of a source is reached, a
+--   new address takes the place of one from the same source that has failed
+--   to connect, if there is one. Addresses that work, or have not been tried,
+--   stay.
+--
+-- * __Random choice.__ 'takeAddress' picks among the addresses that can be
+--   tried at random, as Bitcoin Core's address manager does. It used to take
+--   the first one in the order of the map, which for socket addresses is the
+--   order of the port, so an attacker that gossiped addresses with low ports
+--   was always tried first. The randomness is an input, so that the book
+--   stays pure.
+--
 -- * __Pure, with time as an input.__ Every transition takes the current time,
 --   so the timing rules can be tested without waiting. "Haskoin.Node.PeerMgr"
 --   keeps the book in a 'Control.Concurrent.STM.TVar'.
@@ -43,6 +61,7 @@
     markConnected,
     finishAddress,
     addressState,
+    addressSource,
     needsReload,
     markLoaded,
     knownAddresses,
@@ -54,19 +73,23 @@
   )
 where
 
-import Data.List (find)
 import Data.Map.Strict (Map)
 import Data.Map.Strict qualified as Map
 import Data.Maybe (isNothing)
+import Data.Set (Set)
+import Data.Set qualified as Set
 import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, diffUTCTime)
+import Data.Word (Word64)
 
 -- | Where an address came from.
 data Source
   = -- | the static peers of the configuration
     Configured
-  | -- | DNS seeds, or addresses relayed by peers
+  | -- | the DNS seeds of the network
+    Seeded
+  | -- | relayed by peers
     Discovered
-  deriving stock (Eq, Show)
+  deriving stock (Eq, Ord, Show)
 
 -- | Whether an address can be tried.
 data AddressState
@@ -98,11 +121,23 @@
   }
   deriving stock (Eq, Show)
 
--- | Known addresses, and when the configured peers and seeds were last
--- loaded.
+-- | Known addresses, how many of them came from seeds and from gossip, the
+-- ones that may make room for a new address, and when the configured peers
+-- and seeds were last loaded.
+--
+-- The counts and the index are kept in step with the entries by 'putEntry',
+-- through which every change goes, so that learning an address never scans
+-- the book.
 data AddressBook a = AddressBook
   { entries :: !(Map a Entry),
-    loaded :: !(Maybe UTCTime)
+    loaded :: !(Maybe UTCTime),
+    -- | how many entries are 'Seeded'
+    seeded :: !Int,
+    -- | how many entries are 'Discovered'
+    discovered :: !Int,
+    -- | seed and gossiped addresses that failed and are not in use, by
+    -- source, with their failures in a row (see 'replaceable')
+    failing :: !(Map Source (Set (Int, a)))
   }
   deriving stock (Eq, Show)
 
@@ -122,37 +157,64 @@
 reloadInterval :: NominalDiffTime
 reloadInterval = 300
 
--- | Most discovered addresses kept.
+-- | Most addresses kept from each of the DNS seeds and gossip.
 maxDiscovered :: Int
 maxDiscovered = 4096
 
 -- | No addresses, never loaded.
 emptyBook :: AddressBook a
-emptyBook = AddressBook {entries = Map.empty, loaded = Nothing}
+emptyBook =
+  AddressBook
+    { entries = Map.empty,
+      loaded = Nothing,
+      seeded = 0,
+      discovered = 0,
+      failing = Map.empty
+    }
 
 -- | Learn an address. A known address keeps its state; one from the
--- configuration is marked 'Configured'. A discovered address is dropped if
--- 'maxDiscovered' are known already.
+-- configuration is marked 'Configured'. When 'maxDiscovered' addresses from
+-- the same source are known already, a new seed or gossiped address takes
+-- the place of one from that source that has failed to connect and is not in
+-- use, the one with the most failures in a row. If there is none, the new
+-- address is dropped.
 addAddress :: (Ord a) => Source -> a -> AddressBook a -> AddressBook a
 addAddress src a book =
   case Map.lookup a book.entries of
     Just e
-      | src == Configured -> put e {source = Configured}
+      | src == Configured -> setEntry a e {source = Configured} book
       | otherwise -> book
     Nothing
-      | src == Discovered && discovered >= maxDiscovered -> book
-      | otherwise -> put Entry {source = src, state = Ready, failures = 0}
+      | src == Configured -> fresh book
+      | sourceCount src book < maxDiscovered -> fresh book
+      | otherwise -> case evictable of
+          Just old -> fresh (forget old book)
+          Nothing -> book
   where
-    put e = book {entries = Map.insert a e book.entries}
-    discovered = Map.size (Map.filter ((== Discovered) . (.source)) book.entries)
+    fresh = setEntry a Entry {source = src, state = Ready, failures = 0}
+    -- the one with the most failures, and the greatest address among those
+    evictable = snd <$> (Set.lookupMax =<< Map.lookup src book.failing)
 
 -- | Take an address to connect to: a 'Ready' one, or a 'Waiting' one whose
 -- time has come. It becomes 'InUse'.
-takeAddress :: (Ord a) => UTCTime -> AddressBook a -> Maybe (a, AddressBook a)
-takeAddress now book = do
-  (a, e) <- find (ready . snd) (Map.toList book.entries)
-  return (a, setEntry a e {state = InUse} book)
+--
+-- Configured addresses come first, in order. Otherwise the address is picked
+-- at random, using the given number, among the seed and gossiped addresses
+-- that the predicate allows. "Haskoin.Node.PeerMgr" uses the predicate to
+-- skip addresses in a network group that it is connected to already.
+takeAddress ::
+  (Ord a) => UTCTime -> Word64 -> (a -> Bool) -> AddressBook a -> Maybe (a, AddressBook a)
+takeAddress now r allowed book =
+  case filter ((== Configured) . (.source) . snd) candidates of
+    (a, e) : _ -> Just (take_ a e)
+    [] -> case filter (allowed . fst) candidates of
+      [] -> Nothing
+      others ->
+        let (a, e) = others !! fromIntegral (r `mod` fromIntegral (length others))
+         in Just (take_ a e)
   where
+    candidates = filter (ready . snd) (Map.toList book.entries)
+    take_ a e = (a, setEntry a e {state = InUse} book)
     ready e = case e.state of
       Ready -> True
       InUse -> False
@@ -186,11 +248,15 @@
 addressState :: (Ord a) => a -> AddressBook a -> Maybe AddressState
 addressState a book = (.state) <$> Map.lookup a book.entries
 
+-- | Where an address came from, or 'Nothing' if it is not known.
+addressSource :: (Ord a) => a -> AddressBook a -> Maybe Source
+addressSource a book = (.source) <$> Map.lookup a book.entries
+
 -- | Whether to load the configured peers and seeds: when no address can be
 -- tried now, and they were never loaded or not loaded for 'reloadInterval'.
 needsReload :: (Ord a) => UTCTime -> AddressBook a -> Bool
 needsReload now book =
-  isNothing (takeAddress now book)
+  isNothing (takeAddress now 0 (const True) book)
     && maybe True (\t -> now `diffUTCTime` t >= reloadInterval) book.loaded
 
 -- | The configured peers and seeds were loaded at the given time.
@@ -202,7 +268,52 @@
 knownAddresses book = Map.keys book.entries
 
 setEntry :: (Ord a) => a -> Entry -> AddressBook a -> AddressBook a
-setEntry a e book = book {entries = Map.insert a e book.entries}
+setEntry a e = putEntry a (Just e)
 
+-- | Remove an address.
+forget :: (Ord a) => a -> AddressBook a -> AddressBook a
+forget a = putEntry a Nothing
+
 adjust :: (Ord a) => (Entry -> Entry) -> a -> AddressBook a -> AddressBook a
-adjust f a book = book {entries = Map.adjust f a book.entries}
+adjust f a book = case Map.lookup a book.entries of
+  Nothing -> book
+  Just e -> putEntry a (Just (f e)) book
+
+-- | Whether an entry may make room for a new address from its source: it is
+-- a seed or gossiped address that failed and is not in use.
+replaceable :: Entry -> Bool
+replaceable e = e.source /= Configured && e.failures > 0 && e.state /= InUse
+
+-- | Set the entry of an address, or remove it with 'Nothing'. The counts of
+-- seed and gossiped addresses and the index of 'replaceable' ones follow.
+putEntry :: (Ord a) => a -> Maybe Entry -> AddressBook a -> AddressBook a
+putEntry a new book =
+  maybe id include new . maybe id exclude old $
+    book {entries = Map.alter (const new) a book.entries}
+  where
+    old = Map.lookup a book.entries
+    exclude e b =
+      count e.source (-1) $
+        if replaceable e
+          then b {failing = Map.adjust (Set.delete (e.failures, a)) e.source b.failing}
+          else b
+    include e b =
+      count e.source 1 $
+        if replaceable e
+          then b {failing = Map.insertWith Set.union e.source (Set.singleton (e.failures, a)) b.failing}
+          else b
+
+-- | Change the count of addresses from a source. Configured addresses are
+-- not counted.
+count :: Source -> Int -> AddressBook a -> AddressBook a
+count src n book = case src of
+  Configured -> book
+  Seeded -> book {seeded = book.seeded + n}
+  Discovered -> book {discovered = book.discovered + n}
+
+-- | How many addresses from a source are known.
+sourceCount :: Source -> AddressBook a -> Int
+sourceCount src book = case src of
+  Configured -> 0
+  Seeded -> book.seeded
+  Discovered -> book.discovered
diff --git a/src/Haskoin/Node/PeerMgr/Handshake.hs b/src/Haskoin/Node/PeerMgr/Handshake.hs
--- a/src/Haskoin/Node/PeerMgr/Handshake.hs
+++ b/src/Haskoin/Node/PeerMgr/Handshake.hs
@@ -43,7 +43,7 @@
 
 import Data.Bits ((.&.))
 import Data.Word (Word64)
-import Haskoin (Version (..), nodeNetwork)
+import Haskoin (Network (..), Version (..), nodeNetwork, nodeWitness)
 
 -- | How far the handshake with a peer has progressed.
 data Handshake
@@ -81,6 +81,8 @@
     DuplicateVerAck
   | -- | the peer does not serve the full block chain
     NotFullNode
+  | -- | the peer does not serve witness data, on a network with SegWit
+    NotWitnessNode
   | -- | the version carries one of our own nonces: we connected to ourselves
     ConnectedToSelf
   deriving stock (Eq, Show)
@@ -128,15 +130,20 @@
   Established _ -> True
   _ -> False
 
--- | Check the version of a peer before accepting it. Takes the nonces of the
--- version messages that we sent to all our peers.
+-- | Check the version of a peer before accepting it. Takes the network and
+-- the nonces of the version messages that we sent to all our peers.
 --
 -- A peer must serve the full chain ('nodeNetwork'), because the node syncs
--- headers and applications download blocks from it. A version carrying one of
--- our nonces means the node connected to itself, which happens when it learns
--- its own address from gossip.
-checkVersion :: [Word64] -> Version -> Either HandshakeError Version
-checkVersion nonces v
+-- headers and applications download blocks from it. On a network with SegWit
+-- it must also serve witness data ('nodeWitness'), because
+-- 'Haskoin.Node.Peer.getBlocks' and 'Haskoin.Node.Peer.getTxs' ask for
+-- blocks and transactions with their witness. Bitcoin Core
+-- 32.1 requires both of its outbound peers (@GetDesirableServiceFlags@). A
+-- version carrying one of our nonces means the node connected to itself,
+-- which happens when it learns its own address from gossip.
+checkVersion :: Network -> [Word64] -> Version -> Either HandshakeError Version
+checkVersion net nonces v
   | v.services .&. nodeNetwork == 0 = Left NotFullNode
+  | net.segWit && v.services .&. nodeWitness == 0 = Left NotWitnessNode
   | v.nonce `elem` nonces = Left ConnectedToSelf
   | otherwise = Right v
diff --git a/test/common/Haskoin/Node/Test.hs b/test/common/Haskoin/Node/Test.hs
--- a/test/common/Haskoin/Node/Test.hs
+++ b/test/common/Haskoin/Node/Test.hs
@@ -17,6 +17,10 @@
     headersMessage,
     nowTimestamp,
 
+    -- * Blocks from Bitcoin Core
+    corePreSegWitBlock,
+    coreSegWitBlock,
+
     -- * Database
     withTestDB,
     withDBAt,
@@ -30,6 +34,7 @@
     remoteReceiveMatch,
     remoteClose,
     remoteVersion,
+    fullNodeServices,
     respondHonestly,
     honestRemote,
     encodeMessage,
@@ -48,12 +53,14 @@
 
 import Conduit (awaitForever, yield)
 import Control.Monad (forM_, unless)
+import Data.Bits ((.|.))
 import Data.ByteString (ByteString)
 import Data.ByteString qualified as B
 import Data.Default (def)
 import Data.List (elemIndex)
 import Data.Maybe (fromMaybe, listToMaybe, mapMaybe)
 import Data.Serialize (decode, encode, runGet, runPut)
+import Data.Text (Text)
 import Data.Time.Clock (NominalDiffTime)
 import Data.Time.Clock.POSIX (getPOSIXTime)
 import Data.Word (Word32, Word64)
@@ -181,6 +188,52 @@
 headersMessage :: [BlockHeader] -> Message
 headersMessage hs = MHeaders (Headers [(h, VarInt 0) | h <- hs])
 
+-- | Block 1 of a regtest chain that Bitcoin Core 32.1 mined with
+-- @-testactivationheight=segwit\@200@, so before SegWit was active. Its
+-- hash is @55e949fa...bd71d75@. Core put a witness commitment in the
+-- coinbase but no witness in it, as its miner does before activation, and
+-- Core accepts the block. It has one transaction.
+corePreSegWitBlock :: Block
+corePreSegWitBlock =
+  coreBlock
+    "0000002006226e46111a0b59caaf126043eb5bbf28c34f3a5e332a1fc7b2b73cf188910f010cb977ece0103280894534\
+    \38b7a55c1a016c9fa40c5205571956069623333bd8faf16affff7f200100000001020000000100000000000000000000\
+    \00000000000000000000000000000000000000000000ffffffff025100feffffff0200f2052a010000001976a914636d\
+    \4698f1523dc6688ccccd04850ade37a6c94988ac0000000000000000266a24aa21a9ede2f61c3f71d1defd3fa999dfa3\
+    \6953755c690689799962b48bebd836974e8cf900000000"
+
+-- | Block 302 of the same chain, after SegWit activated. Its hash is
+-- @30f22128...3a62efb@ and its parent is block 301, @7bd5bfeb...b63e52b9@.
+-- It has three transactions: the coinbase, whose witness is the 32-byte
+-- reserved value; a P2WPKH spend, txid @9d304fed...6401d23d@ and wtxid
+-- @a6b593b3...256a158e@; and a legacy spend without witness. Core accepted
+-- it, and gave @bad-witness-merkle-match@ for a block like it whose spend had
+-- one byte of its witness changed.
+coreSegWitBlock :: Block
+coreSegWitBlock =
+  coreBlock
+    "00000030b9523eb63f97c829f511bb532cf784c8827dc52b299f2fd994316deaebbfd57b9fa7b223e45c1d3509c35803\
+    \274fc47a62cdbdd25f8b081e80d3c026577dfe7f0cfbf16affff7f200000000003020000000001010000000000000000\
+    \000000000000000000000000000000000000000000000000ffffffff03022e01feffffff02ea0b834a000000001976a9\
+    \145b0082ee7098f21fb42b61bf40ba80ed4714108288ac0000000000000000266a24aa21a9ed3689d337d76ca8ae1070\
+    \b00bcfde4a16d82ae87ea9307d8705ef1b308792ef750120000000000000000000000000000000000000000000000000\
+    \00000000000000002d0100000200000000010156ed4c57e51a1912b3d4a0c92dec5aa90e5db79f60ee3294490803bea1\
+    \32ef1c0100000000fdffffff01d29f6659000000001976a9142d26b779a8053861ca5d01bf5d3880292280290288ac02\
+    \47304402206b38df4637ea3c6474da4d1310260d3cd9738e0bd496ed33841c02973d65d56f0220465694613885394876\
+    \ff1722e5675fd1e6dec5621b285fca4212c3e4a3135ade0121039e06e681933cef4160b02d907c68e3e54144b9ae0bdf\
+    \d2c696d0d51132c6058c0000000002000000014e4d8f4536ded4cdfb0e1769f70e60904ee6fb6babca4cdf0dbf522030\
+    \3c8985000000006a473044022013d2f4e1bd3a3f304d9028a4d1e3b4157989ac0481934c6250d8a29595b873d302201e\
+    \df49731a27af137e0e0b6aee291d940db33033bbcebec78311c67650194472012102034d48cf5a3fcbd59d813ab02bec\
+    \67ca2b351830ce6931a76c2ffe2529433d87fdffffff02f67e8b3b000000001976a914ca4b520b0a1c5d5595e337cd1f\
+    \945bc9e2860b8c88ac40717759000000001976a9142b83d6a87a77b0f96f812d4df53830a64f6a909e88ac2d010000"
+
+-- | A block from its serialization in hex, as @getblock@ prints it.
+coreBlock :: Text -> Block
+coreBlock hex =
+  case decode =<< maybe (Left "bad hex") Right (decodeHex hex) of
+    Left e -> error ("coreBlock: " <> e)
+    Right b -> b
+
 -- | Temporary RocksDB database.
 withTestDB :: (DB -> IO a) -> IO a
 withTestDB f =
@@ -283,6 +336,13 @@
 zeroAddress :: Word64 -> NetworkAddress
 zeroAddress srv = NetworkAddress srv (sockToHostAddress (SockAddrInet 0 0))
 
+-- | Services that a full node of the network offers, as Bitcoin Core does:
+-- the full chain, and witness data on a network with SegWit.
+fullNodeServices :: Network -> Word64
+fullNodeServices net
+  | net.segWit = nodeNetwork .|. nodeWitness
+  | otherwise = nodeNetwork
+
 -- | Version message for a remote peer.
 remoteVersion :: Network -> Word64 -> Word64 -> IO Version
 remoteVersion net services nonce = do
@@ -320,7 +380,7 @@
 -- | Remote that completes the handshake and serves the provided blocks.
 honestRemote :: TVar [Block] -> Remote -> IO ()
 honestRemote blocks r = do
-  v <- remoteVersion r.net nodeNetwork =<< randomIO
+  v <- remoteVersion r.net (fullNodeServices r.net) =<< randomIO
   remoteSend r (MVersion v)
   let go =
         remoteReceive r >>= \case
diff --git a/test/regtest/Containerfile b/test/regtest/Containerfile
--- a/test/regtest/Containerfile
+++ b/test/regtest/Containerfile
@@ -1,7 +1,7 @@
 # Regtest image with official Bitcoin Core and Bitcoin Cash Node binaries.
 #
 # Build with:
-#   podman build -t haskoin-node-regtest regtest
+#   podman build -t haskoin-node-regtest test/regtest
 #
 # Hashes come from the official SHA256SUMS files published by each project:
 #   https://bitcoincore.org/bin/bitcoin-core-32.1/SHA256SUMS
@@ -16,31 +16,17 @@
 ARG BCHN_SHA256_amd64=23bbe9ff749136a9b832a2a59023ce76a5391322c1ea2f4f24b5b91f035081bc
 ARG BCHN_SHA256_arm64=27e177e5a07dc78c2c0d18798ea2e3925111955509ecdc476e828e7ce8f46383
 
+# One RUN step, so that the image keeps no package lists.
 RUN apt-get update \
- && apt-get install -y --no-install-recommends ca-certificates curl libatomic1 \
+ && apt-get install -y --no-install-recommends \
+      ca-certificates \
+      curl \
+      libatomic1 \
  && rm -rf /var/lib/apt/lists/*
 
-RUN set -eu; \
-    arch="${TARGETARCH:-$(dpkg --print-architecture)}"; \
-    case "$arch" in \
-      amd64) triple=x86_64-linux-gnu; core_sha="$CORE_SHA256_amd64"; bchn_sha="$BCHN_SHA256_amd64" ;; \
-      arm64) triple=aarch64-linux-gnu; core_sha="$CORE_SHA256_arm64"; bchn_sha="$BCHN_SHA256_arm64" ;; \
-      *) echo "unsupported architecture: $arch" >&2; exit 1 ;; \
-    esac; \
-    cd /tmp; \
-    core="bitcoin-${CORE_VERSION}-${triple}.tar.gz"; \
-    curl -fsSLO "https://bitcoincore.org/bin/bitcoin-core-${CORE_VERSION}/${core}"; \
-    echo "${core_sha}  ${core}" | sha256sum -c -; \
-    mkdir -p /opt/bitcoin-core; \
-    tar -xzf "$core" -C /opt/bitcoin-core --strip-components=1; \
-    bchn="bitcoin-cash-node-${BCHN_VERSION}-${triple}.tar.gz"; \
-    curl -fsSLO "https://github.com/bitcoin-cash-node/bitcoin-cash-node/releases/download/v${BCHN_VERSION}/${bchn}"; \
-    echo "${bchn_sha}  ${bchn}" | sha256sum -c -; \
-    mkdir -p /opt/bchn; \
-    tar -xzf "$bchn" -C /opt/bchn --strip-components=1; \
-    rm -f /tmp/*.tar.gz; \
-    /opt/bitcoin-core/bin/bitcoind -version | head -1; \
-    /opt/bchn/bin/bitcoind -version | head -1
+# The script reads the versions and hashes above from the build arguments.
+COPY install-nodes.sh /usr/local/bin/install-nodes.sh
+RUN /usr/local/bin/install-nodes.sh
 
 # Peer-to-peer ports for up to three nodes per container.
 EXPOSE 18444 18445 18446
diff --git a/test/regtest/Regtest/Podman.hs b/test/regtest/Regtest/Podman.hs
--- a/test/regtest/Regtest/Podman.hs
+++ b/test/regtest/Regtest/Podman.hs
@@ -63,7 +63,8 @@
 image :: String
 image = "localhost/haskoin-node-regtest:latest"
 
--- | Directory with the Containerfile, relative to the package root.
+-- | Build context of the image: the directory with the Containerfile and the
+-- @install-nodes.sh@ script it runs, relative to the package root.
 imageDir :: FilePath
 imageDir = "test/regtest"
 
diff --git a/test/regtest/install-nodes.sh b/test/regtest/install-nodes.sh
new file mode 100644
--- /dev/null
+++ b/test/regtest/install-nodes.sh
@@ -0,0 +1,61 @@
+#!/bin/sh
+# Install the official Bitcoin Core and Bitcoin Cash Node release binaries
+# into /opt/bitcoin-core and /opt/bchn, after checking their SHA-256 hashes.
+#
+# The Containerfile runs this while building the regtest image. It reads the
+# versions and hashes from the build arguments declared there:
+# CORE_VERSION, BCHN_VERSION, and CORE_SHA256_<arch> and BCHN_SHA256_<arch>
+# for each supported architecture.
+set -eu
+
+# Podman sets TARGETARCH; fall back to the architecture of the build host.
+arch="${TARGETARCH:-$(dpkg --print-architecture)}"
+
+case "$arch" in
+  amd64)
+    triple=x86_64-linux-gnu
+    core_sha="$CORE_SHA256_amd64"
+    bchn_sha="$BCHN_SHA256_amd64"
+    ;;
+  arm64)
+    triple=aarch64-linux-gnu
+    core_sha="$CORE_SHA256_arm64"
+    bchn_sha="$BCHN_SHA256_arm64"
+    ;;
+  *)
+    echo "unsupported architecture: $arch" >&2
+    exit 1
+    ;;
+esac
+
+# Download a release tarball, check its hash and unpack it into a directory.
+install_release() {
+  url="$1"
+  sha="$2"
+  dest="$3"
+  file="${url##*/}"
+  curl -fsSLO "$url"
+  echo "${sha}  ${file}" | sha256sum -c -
+  mkdir -p "$dest"
+  tar -xzf "$file" -C "$dest" --strip-components=1
+  rm -f "$file"
+}
+
+cd /tmp
+
+core_base="https://bitcoincore.org/bin/bitcoin-core-${CORE_VERSION}"
+install_release \
+  "${core_base}/bitcoin-${CORE_VERSION}-${triple}.tar.gz" \
+  "$core_sha" \
+  /opt/bitcoin-core
+
+bchn_base="https://github.com/bitcoin-cash-node/bitcoin-cash-node"
+bchn_base="${bchn_base}/releases/download/v${BCHN_VERSION}"
+install_release \
+  "${bchn_base}/bitcoin-cash-node-${BCHN_VERSION}-${triple}.tar.gz" \
+  "$bchn_sha" \
+  /opt/bchn
+
+# Show the installed versions in the build log.
+/opt/bitcoin-core/bin/bitcoind -version | head -1
+/opt/bchn/bin/bitcoind -version | head -1
diff --git a/test/unit/Haskoin/Node/AddressSpec.hs b/test/unit/Haskoin/Node/AddressSpec.hs
--- a/test/unit/Haskoin/Node/AddressSpec.hs
+++ b/test/unit/Haskoin/Node/AddressSpec.hs
@@ -1,14 +1,123 @@
 module Haskoin.Node.AddressSpec (spec) where
 
+import Control.Exception (IOException, bracket, try)
 import Control.Monad (forM_)
+import Data.Time.Clock (diffUTCTime, getCurrentTime)
+import Data.Word (Word16, Word8)
 import Haskoin (Network (..), btcRegTest)
 import Haskoin.Node (toHostService, toSockAddr)
-import Network.Socket (SockAddr (..))
+import Haskoin.Node.Address (NetGroup (..), isRoutable, netGroup, withConnection)
+import Network.Socket
+  ( Family (AF_INET),
+    SockAddr (..),
+    SocketType (Stream),
+    bind,
+    close,
+    connect,
+    defaultProtocol,
+    listen,
+    socket,
+    socketPort,
+    tupleToHostAddress,
+    tupleToHostAddress6,
+  )
 import Test.Hspec
 import Test.Hspec.QuickCheck (prop)
 
+v4 :: (Word8, Word8, Word8, Word8) -> SockAddr
+v4 = SockAddrInet 8333 . tupleToHostAddress
+
+v6 :: (Word16, Word16, Word16, Word16, Word16, Word16, Word16, Word16) -> SockAddr
+v6 t = SockAddrInet6 8333 0 (tupleToHostAddress6 t) 0
+
 spec :: Spec
 spec = do
+  describe "routable addresses" $ do
+    it "refuses the reserved IPv4 ranges" $
+      forM_
+        [ (198, 18, 0, 1), -- benchmarking, 198.18.0.0/15
+          (198, 19, 255, 1),
+          (192, 0, 2, 1), -- documentation
+          (198, 51, 100, 1),
+          (203, 0, 113, 1),
+          (0, 1, 2, 3), -- this network
+          (192, 0, 0, 1) -- protocol assignments
+        ]
+        $ \a -> isRoutable (v4 a) `shouldBe` False
+
+    it "accepts the addresses just outside the benchmarking range" $ do
+      isRoutable (v4 (198, 17, 255, 1)) `shouldBe` True
+      isRoutable (v4 (198, 20, 0, 1)) `shouldBe` True
+
+    it "refuses the reserved IPv6 ranges" $
+      forM_
+        [ (0xff02, 0, 0, 0, 0, 0, 0, 1), -- multicast
+          (0xfec0, 0, 0, 0, 0, 0, 0, 1), -- site-local
+          (0x2001, 0x0db8, 0, 0, 0, 0, 0, 1) -- documentation
+        ]
+        $ \a -> isRoutable (v6 a) `shouldBe` False
+
+    it "refuses the ORCHID ranges, as Bitcoin Core does" $
+      -- RFC 4843: 2001:10::/28; RFC 7343: 2001:20::/28
+      forM_ [0x0010, 0x001f, 0x0020, 0x002f] $ \b ->
+        isRoutable (v6 (0x2001, b, 0, 0, 0, 0, 0, 1)) `shouldBe` False
+
+    it "accepts the addresses just outside the ORCHID ranges" $
+      forM_ [0x000f, 0x0030] $ \b ->
+        isRoutable (v6 (0x2001, b, 0, 0, 0, 0, 0, 1)) `shouldBe` True
+
+  describe "connections" $ do
+    it "gives up opening a connection that gets no answer after five seconds" $ do
+      -- Bitcoin Core: DEFAULT_CONNECT_TIMEOUT = 5000 ms. A listening socket
+      -- whose queue of one connection is full drops new requests on Linux,
+      -- so opening a connection to it hangs.
+      let loopback = tupleToHostAddress (127, 0, 0, 1)
+          listener = do
+            s <- socket AF_INET Stream defaultProtocol
+            bind s (SockAddrInet 0 loopback)
+            listen s 0
+            return s
+      bracket listener close $ \srv -> do
+        port <- socketPort srv
+        let sa = SockAddrInet port loopback
+        bracket (socket AF_INET Stream defaultProtocol) close $ \filler -> do
+          connect filler sa
+          start <- getCurrentTime
+          r <- try (withConnection sa (\_ -> return ()))
+          end <- getCurrentTime
+          either (\(_ :: IOException) -> True) (const False) r `shouldBe` True
+          end `diffUTCTime` start `shouldSatisfy` (\d -> d >= 4.5 && d < 8)
+
+  describe "network groups" $ do
+    -- 45.1.2.3 is 0x2d010203.
+    it "groups IPv4 addresses by their first two bytes, whatever the port" $ do
+      netGroup (SockAddrInet 1000 (tupleToHostAddress (45, 1, 2, 3))) `shouldBe` IPv4Group 45 1
+      netGroup (v4 (45, 1, 200, 9)) `shouldBe` IPv4Group 45 1
+      netGroup (v4 (45, 2, 0, 1)) `shouldBe` IPv4Group 45 2
+
+    it "groups IPv6 addresses that carry an IPv4 address by that address" $ do
+      netGroup (v6 (0, 0, 0, 0, 0, 0xffff, 0x2d01, 0x0203)) `shouldBe` IPv4Group 45 1
+      netGroup (v6 (0x0064, 0xff9b, 0, 0, 0, 0, 0x2d01, 0x0203)) `shouldBe` IPv4Group 45 1
+      netGroup (v6 (0x2002, 0x2d01, 0x0203, 0, 0, 0, 0, 1)) `shouldBe` IPv4Group 45 1
+      -- Teredo inverts the bits: 0xffffffff - 0x2d010203 = 0xd2fefdfc
+      netGroup (v6 (0x2001, 0, 0, 0, 0, 0, 0xd2fe, 0xfdfc)) `shouldBe` IPv4Group 45 1
+
+    it "groups other IPv6 addresses by their first four bytes" $ do
+      netGroup (v6 (0x2a01, 0x04f8, 0x0001, 0, 0, 0, 0, 1))
+        `shouldBe` IPv6Group [0x2a, 0x01, 0x04, 0xf8]
+      netGroup (v6 (0x2a01, 0x04f8, 0xffff, 0, 0, 0, 0, 1))
+        `shouldBe` IPv6Group [0x2a, 0x01, 0x04, 0xf8]
+
+    it "groups Hurricane Electric addresses by 36 bits" $
+      -- the fifth byte 0x12 with its low four bits set: 0x1f
+      netGroup (v6 (0x2001, 0x0470, 0x1234, 0, 0, 0, 0, 1))
+        `shouldBe` IPv6Group [0x20, 0x01, 0x04, 0x70, 0x1f]
+
+    it "puts loopback and unroutable addresses in groups of their own" $ do
+      netGroup (v4 (127, 0, 0, 1)) `shouldBe` LocalGroup
+      netGroup (v6 (0, 0, 0, 0, 0, 0, 0, 1)) `shouldBe` LocalGroup
+      netGroup (v4 (10, 0, 0, 1)) `shouldBe` UnroutableGroup
+
   let net = btcRegTest
   describe "addresses" $ do
     it "parses host and service"
diff --git a/test/unit/Haskoin/Node/BlockSpec.hs b/test/unit/Haskoin/Node/BlockSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/unit/Haskoin/Node/BlockSpec.hs
@@ -0,0 +1,170 @@
+-- | Whether a block holds the transactions its header commits to, against
+-- blocks mined by Bitcoin Core 32.1 and copies of them changed the ways a
+-- peer could change them.
+module Haskoin.Node.BlockSpec (spec) where
+
+import Data.ByteString qualified as B
+import Data.Serialize (encode)
+import Haskoin
+import Haskoin.Node
+import Haskoin.Node.Test (corePreSegWitBlock, coreSegWitBlock)
+import Test.Hspec
+
+-- | The same block with the witness of every transaction removed.
+stripWitness :: Block -> Block
+stripWitness b = b {txs = [tx {witness = []} | tx <- b.txs]}
+
+-- | The same block with the last byte of the last witness item of its
+-- second transaction changed. Only the witness changes, so the txid and the
+-- Merkle root stay the same.
+alterWitness :: Block -> Block
+alterWitness b = case b.txs of
+  cb : tx : rest -> b {txs = cb : tx {witness = map (map flipLast) tx.witness} : rest}
+  _ -> b
+  where
+    flipLast item
+      | B.null item = item
+      | otherwise = B.init item <> B.singleton (B.last item + 1)
+
+-- | A node at the given height, standing for the parent of a block.
+parentAt :: Network -> BlockHeight -> BlockNode
+parentAt net h =
+  BlockNode
+    { header = net.genesisHeader,
+      height = h,
+      work = 0,
+      skip = headerHash net.genesisHeader
+    }
+
+-- | A transaction that is not a coinbase, with an output script of the
+-- given length. Without witness it is 60 bytes plus the script: 4 version
+-- + 1 input count + 41 input + 1 output count + 9 output value and script
+-- length + 4 lock time = 60.
+nonCoinbase :: Int -> Tx
+nonCoinbase n =
+  Tx
+    { version = 1,
+      inputs =
+        [ TxIn
+            { outpoint = OutPoint {hash = spent, index = 0},
+              script = B.empty,
+              sequence = 0
+            }
+        ],
+      outputs = [TxOut {value = 1, script = B.replicate n 0x51}],
+      witness = [],
+      locktime = 0
+    }
+  where
+    spent = "1111111111111111111111111111111111111111111111111111111111111111"
+
+-- | A block with the given transactions under a header that commits to them.
+blockOf :: [Tx] -> Block
+blockOf txs =
+  Block
+    { header =
+        btcRegTest.genesisHeader
+          { merkle = either error id (buildMerkleRoot (map txHash txs))
+          },
+      txs = txs
+    }
+
+spec :: Spec
+spec = do
+  describe "Bitcoin Core blocks used as fixtures" $ do
+    it "are the blocks that Bitcoin Core printed" $ do
+      headerHash corePreSegWitBlock.header
+        `shouldBe` "55e949faadd10136287852156f9078c4ba8cadd1b602697ff4202b395bd71d75"
+      headerHash coreSegWitBlock.header
+        `shouldBe` "30f221284bb2468933c8a37992771939bf4257cebfb4191f7c0fab5703a62efb"
+      map txHash coreSegWitBlock.txs
+        `shouldBe` [ "7581bf22701c376882dac3d3d70a86e9341a35eb32bcd797f47619907f54a81e",
+                     "9d304fed9ba3333c3cf6c23739376e5b740b3c181ebd08578dab63dc6401d23d",
+                     "8ba9b11d4a6a205d5dd4625c71f2fb7292c08926a87c5f622bf38c09980f49c4"
+                   ]
+      map txWitnessHash coreSegWitBlock.txs
+        `shouldBe` [ "67188a253a1f92310c43db8ebc98cb5b3b6cb26668710402f2362e29193b2758",
+                     "a6b593b3a88dba0efcfe44d125eaf1c8413be672519300d001458197256a158e",
+                     "8ba9b11d4a6a205d5dd4625c71f2fb7292c08926a87c5f622bf38c09980f49c4"
+                   ]
+
+  describe "blockMutation" $ do
+    it "accepts a SegWit block that Bitcoin Core mined" $
+      blockMutation SegWitActive coreSegWitBlock `shouldBe` Nothing
+
+    it "accepts a block mined before SegWit with a commitment but no coinbase witness" $
+      blockMutation SegWitInactive corePreSegWitBlock `shouldBe` Nothing
+
+    it "would refuse that block if SegWit applied to it, so the height must be known" $
+      -- Core's miner adds the commitment before activation, but not the
+      -- 32-byte value in the coinbase witness that goes with it.
+      blockMutation SegWitActive corePreSegWitBlock `shouldBe` Just BadWitnessNonceSize
+
+    it "refuses a block whose transactions do not hash to the Merkle root" $ do
+      -- Bitcoin Core: bad-txnmrklroot
+      let b = coreSegWitBlock {txs = take 2 coreSegWitBlock.txs}
+      blockMutation SegWitActive b `shouldBe` Just BadMerkleRoot
+
+    it "refuses a block that repeats its last transaction to keep the Merkle root" $ do
+      -- CVE-2012-2459. Bitcoin Core: bad-txns-duplicate. Three transactions
+      -- and the same three with the last one repeated give the same root,
+      -- because an odd level pairs its last node with itself.
+      let b = coreSegWitBlock {txs = coreSegWitBlock.txs <> drop 2 coreSegWitBlock.txs}
+      length b.txs `shouldBe` 4
+      blockMutation SegWitActive b `shouldBe` Just DuplicateTransactions
+
+    it "refuses a block without transactions" $ do
+      let b = coreSegWitBlock {txs = []}
+      blockMutation SegWitActive b `shouldBe` Just BadMerkleRoot
+
+    it "refuses a SegWit block whose witness data was stripped" $
+      -- The coinbase loses its 32-byte reserved value first.
+      blockMutation SegWitActive (stripWitness coreSegWitBlock)
+        `shouldBe` Just BadWitnessNonceSize
+
+    it "refuses a SegWit block whose witness data was changed" $
+      -- Bitcoin Core gave bad-witness-merkle-match for such a block.
+      blockMutation SegWitActive (alterWitness coreSegWitBlock)
+        `shouldBe` Just BadWitnessCommitment
+
+    it "refuses witness data in a block for which SegWit is not active" $
+      -- Bitcoin Core: unexpected-witness
+      blockMutation SegWitInactive coreSegWitBlock `shouldBe` Just UnexpectedWitness
+
+    it "does not check the witness data of a block whose height is unknown" $
+      blockMutation WitnessUnknown (alterWitness coreSegWitBlock) `shouldBe` Nothing
+
+    it "still checks the Merkle root of a block whose height is unknown" $ do
+      let b = coreSegWitBlock {txs = take 2 coreSegWitBlock.txs}
+      blockMutation WitnessUnknown b `shouldBe` Just BadMerkleRoot
+
+    it "refuses a block without a coinbase that holds a 64-byte transaction" $ do
+      -- 60 + 4 script bytes = 64
+      B.length (encode (nonCoinbase 4)) `shouldBe` 64
+      blockMutation SegWitActive (blockOf [nonCoinbase 4])
+        `shouldBe` Just SixtyFourByteTransaction
+
+    it "leaves other blocks without a coinbase to block validation" $ do
+      -- 60 + 5 script bytes = 65
+      B.length (encode (nonCoinbase 5)) `shouldBe` 65
+      blockMutation SegWitActive (blockOf [nonCoinbase 5]) `shouldBe` Nothing
+
+  describe "witnessCheck" $ do
+    it "applies the witness rule on Bitcoin from block 481824" $ do
+      witnessCheck btc (Just (parentAt btc 481822)) `shouldBe` SegWitInactive
+      witnessCheck btc (Just (parentAt btc 481823)) `shouldBe` SegWitActive
+
+    it "applies the witness rule on testnet3 from block 834624" $ do
+      witnessCheck btcTest (Just (parentAt btcTest 834622)) `shouldBe` SegWitInactive
+      witnessCheck btcTest (Just (parentAt btcTest 834623)) `shouldBe` SegWitActive
+
+    it "applies the witness rule on testnet4 and regtest from the first block" $ do
+      witnessCheck btcTest4 (Just (parentAt btcTest4 0)) `shouldBe` SegWitActive
+      witnessCheck btcRegTest (Just (parentAt btcRegTest 0)) `shouldBe` SegWitActive
+
+    it "leaves the witness unchecked when the parent is unknown" $
+      witnessCheck btc Nothing `shouldBe` WitnessUnknown
+
+    it "allows no witness data on Bitcoin Cash, whatever the height" $ do
+      witnessCheck bch Nothing `shouldBe` SegWitInactive
+      witnessCheck bch (Just (parentAt bch 800000)) `shouldBe` SegWitInactive
diff --git a/test/unit/Haskoin/Node/Chain/SyncSpec.hs b/test/unit/Haskoin/Node/Chain/SyncSpec.hs
--- a/test/unit/Haskoin/Node/Chain/SyncSpec.hs
+++ b/test/unit/Haskoin/Node/Chain/SyncSpec.hs
@@ -27,6 +27,8 @@
   | Finish Int
   | Drop Int
   | Poll
+  | Ask Int
+  | Answer Int
   deriving stock (Show)
 
 instance Arbitrary Op where
@@ -39,7 +41,9 @@
         Refresh <$> peer,
         Finish <$> peer,
         Drop <$> peer,
-        pure Poll
+        pure Poll,
+        Ask <$> peer,
+        Answer <$> peer
       ]
     where
       peer = chooseInt (1, 4)
@@ -49,11 +53,13 @@
   Connect p -> peerConnected p s
   Disconnect p -> peerDisconnected p s
   Request p -> requestSync p s
-  Start p -> startSync (at 1) p s
+  Start p -> startSync (at 1) (at 1000) p s
   Refresh p -> refreshSync (at 2) p s
   Finish p -> finishSync p s
   Drop p -> dropPeer p s
   Poll -> pollPeers (at 3) s
+  Ask p -> askHeaders (at 4) p s
+  Answer p -> gotHeaders p s
 
 states :: [Op] -> [SyncState Int]
 states = scanl apply (emptySync t0)
@@ -131,6 +137,47 @@
     it "is not synced while a peer is queued or syncing" $ do
       isSynced net now recent (run [Connect 1]) `shouldBe` False
       isSynced net now recent (run [Connect 1, Start 1]) `shouldBe` False
+    it "is synced with a tip exactly two hours old, and not one second older" $ do
+      -- two hours = 7200 seconds, the most a block may be ahead of the clock
+      let nowSecs = floor (utcTimeToPOSIXSeconds now)
+      isSynced net now (tipAt (nowSecs - 7200) 1) idle `shouldBe` True
+      isSynced net now (tipAt (nowSecs - 7201) 1) idle `shouldBe` False
+
+  describe "deadline of a turn" $ do
+    let net = btcRegTest
+        bestAt t =
+          BlockNode
+            { header = net.genesisHeader {timestamp = t},
+              height = 1,
+              work = 1,
+              skip = headerHash net.genesisHeader
+            }
+        tipSecs = floor (utcTimeToPOSIXSeconds t0)
+    it "is 15 minutes plus 1 ms for each block expected since the best block" $
+      -- 6,000,000 s / 600 s per block = 10,000 blocks x 1 ms = 10 s,
+      -- plus 900 s = 910 s
+      syncDeadline net (at 6000000) (bestAt tipSecs) `shouldBe` at (6000000 + 910)
+    it "is 15 minutes when the best block is not older than now" $
+      syncDeadline net t0 (bestAt (tipSecs + 60)) `shouldBe` at 900
+    it "has passed only after the deadline" $ do
+      let s = run [Connect 1, Connect 2, Start 1]
+      syncTimedOut (at 1000) s `shouldBe` False
+      syncTimedOut (at 1001) s `shouldBe` True
+    it "does not end the turn when no other peer could take over" $ do
+      syncTimedOut (at 1001) (run [Connect 1, Start 1]) `shouldBe` False
+      syncTimedOut (at 1001) (run [Connect 1, Connect 2, Start 1, Drop 2]) `shouldBe` False
+
+  describe "requests in flight" $ do
+    it "does not ask a peer again within two minutes of asking it" $ do
+      let s = askHeaders (at 0) 1 (run [Connect 1])
+      mayAsk (at 120) 1 s `shouldBe` False
+      mayAsk (at 121) 1 s `shouldBe` True
+    it "asks a peer again once it answered" $
+      mayAsk (at 1) 1 (gotHeaders 1 (askHeaders (at 0) 1 (run [Connect 1]))) `shouldBe` True
+    it "keeps track of each peer separately" $
+      mayAsk (at 1) 2 (askHeaders (at 0) 1 (run [Connect 1, Connect 2])) `shouldBe` True
+    it "forgets the requests of a peer that disconnects" $
+      mayAsk (at 1) 1 (run [Connect 1, Ask 1, Disconnect 1, Connect 1]) `shouldBe` True
 
   prop "never syncs against more than one peer" $ \ops ->
     all ((<= 1) . length . filter isSyncingStatus . statuses) (states ops)
diff --git a/test/unit/Haskoin/Node/ChainSpec.hs b/test/unit/Haskoin/Node/ChainSpec.hs
--- a/test/unit/Haskoin/Node/ChainSpec.hs
+++ b/test/unit/Haskoin/Node/ChainSpec.hs
@@ -138,8 +138,25 @@
   expectSendHeaders fp
   return fp
 
+-- | The header with the first nonce for which its hash is above its target.
+-- Only its proof of work is wrong: its bits, time and parent are those of a
+-- valid header.
 invalidPow :: BlockHeader -> BlockHeader
-invalidPow h = h {bits = 0x1d00ffff}
+invalidPow h =
+  case [h' | n <- [0 ..], let h' = withNonce n, blockPOW (headerHash h') > target] of
+    h' : _ -> h'
+    [] -> h
+  where
+    (target, _) = decodeCompact h.bits
+    withNonce n =
+      BlockHeader
+        { version = h.version,
+          prev = h.prev,
+          merkle = h.merkle,
+          timestamp = h.timestamp,
+          bits = h.bits,
+          nonce = n
+        }
 
 spec :: Spec
 spec = forM_ [btcRegTest, bchRegTest] $ \net ->
@@ -256,6 +273,32 @@
           g <- expectGetHeaders b
           take 1 g.locator `shouldBe` [hashAt 2000]
 
+      it "asks a peer that announces an unknown block while another peer syncs" $
+        slow $ \ct -> do
+          a <- connectPeer ct "a"
+          b <- connectPeer ct "b"
+          -- a holds the turn and never answers
+          _ <- expectGetHeaders a
+          chainBlocksAnnounced ct.chain b.peer [hashAt 100]
+          g <- expectGetHeaders b
+          take 1 g.locator `shouldBe` [headerHash net.genesisHeader]
+
+      it "asks an announcing peer only once until it answers" $
+        slow $ \ct -> do
+          a <- connectPeer ct "a"
+          b <- connectPeer ct "b"
+          _ <- expectGetHeaders a
+          chainBlocksAnnounced ct.chain b.peer [hashAt 100]
+          _ <- expectGetHeaders b
+          chainBlocksAnnounced ct.chain b.peer [hashAt 101]
+          sendHeaders ct b (take 5 (drop 49 main))
+          expectNoRequest 1 b
+          -- headers that connect answer the request
+          sendHeaders ct b (take 5 main)
+          _ <- waitHeight ct 5
+          chainBlocksAnnounced ct.chain b.peer [hashAt 102]
+          void $ expectGetHeaders b
+
       it "keeps syncing peer when another peer announces headers" $
         slow $ \ct -> do
           a <- connectPeer ct "a"
@@ -279,6 +322,15 @@
 
     describe "reorganizations" $ do
       let fork n = mkHeaders net 1 (main !! 14) (t0 + 100) n
+      it "keeps the first chain it saw when a fork has the same work" $ slow $ \ct -> do
+        a <- syncPeer ct "a" short
+        -- five headers on block 15 reach height 20, with the same work
+        sendHeaders ct a (fork 5)
+        let tip = headerHash (last (fork 5))
+        eventually 10 "fork stored" $
+          (/= Nothing) <$> chainGetBlock ct.chain tip
+        bestHash ct `shouldReturn` hashAt 20
+
       it "switches to a fork with more work" $ slow $ \ct -> do
         a <- syncPeer ct "a" short
         sendHeaders ct a (fork 10)
@@ -306,6 +358,30 @@
           _ <- expectGetHeaders a
           sendHeaders ct a [invalidPow (main !! 0)]
           expectKilled a
+
+      it "publishes the best block when a batch fails after valid headers" $
+        slow $ \ct -> do
+          a <- connectPeer ct "a"
+          _ <- expectGetHeaders a
+          sendHeaders ct a (take 5 main <> [invalidPow (main !! 5)])
+          expectKilled a
+          bn <- receiveWithin 10 "best block at height 5" ct.events $ \case
+            ChainBestBlock bn | bn.height == 5 -> Just bn
+            _ -> Nothing
+          nodeHash bn `shouldBe` hashAt 5
+
+      it "ends the turn of a peer whose full batch brings no new header" $
+        slow $ \ct -> do
+          a <- connectPeer ct "a"
+          b <- connectPeer ct "b"
+          _ <- answer ct a main
+          _ <- waitHeight ct 2000
+          -- asked for the headers after 2000, a sends the first 2000 again
+          _ <- expectGetHeaders a
+          sendHeaders ct a (take 2000 main)
+          expectSendHeaders a
+          g <- expectGetHeaders b
+          take 1 g.locator `shouldBe` [hashAt 2000]
 
       it "disconnects a peer that sends headers that do not form a chain" $
         slow $ \ct -> do
diff --git a/test/unit/Haskoin/Node/PeerMgr/AddressesSpec.hs b/test/unit/Haskoin/Node/PeerMgr/AddressesSpec.hs
--- a/test/unit/Haskoin/Node/PeerMgr/AddressesSpec.hs
+++ b/test/unit/Haskoin/Node/PeerMgr/AddressesSpec.hs
@@ -1,9 +1,12 @@
 module Haskoin.Node.PeerMgr.AddressesSpec (spec) where
 
-import Data.Maybe (isJust, isNothing)
+import Data.List (nub, sort)
+import Data.Maybe (isJust, isNothing, mapMaybe)
 import Data.Time.Calendar (fromGregorian)
 import Data.Time.Clock (NominalDiffTime, UTCTime (..), addUTCTime)
+import Data.Word (Word64)
 import Haskoin.Node.PeerMgr.Addresses
+import Network.Socket (SockAddr (..), tupleToHostAddress)
 import Test.Hspec
 import Test.Hspec.QuickCheck (prop)
 import Test.QuickCheck
@@ -17,18 +20,28 @@
 book :: [Int] -> AddressBook Int
 book = foldl' (flip (addAddress Discovered)) emptyBook
 
+-- | Take an address, with any address allowed.
+takeAny :: (Ord a) => UTCTime -> AddressBook a -> Maybe (a, AddressBook a)
+takeAny now = takeAddress now 0 (const True)
+
 -- | Take an address that must be available.
 taken :: UTCTime -> AddressBook Int -> (Int, AddressBook Int)
-taken now b = case takeAddress now b of
+taken now b = case takeAny now b of
   Just x -> x
   Nothing -> error "no address to take"
 
--- | Take an address, end its connection, and return the new book.
+-- | Take a given address, end its connection, and return the new book. Only
+-- that address may be taken.
 cycleWith :: Outcome -> Int -> AddressBook Int -> AddressBook Int
-cycleWith outcome a b = case takeAddress t0 b of
+cycleWith outcome a b = case takeAddress t0 0 (== a) b of
   Just (a', b') | a == a' -> finishAddress t0 outcome a b'
   _ -> error "address not taken"
 
+-- | Every address that some random number makes 'takeAddress' pick, sorted.
+picks :: (Ord a) => (a -> Bool) -> AddressBook a -> [a]
+picks allowed b =
+  sort (nub (mapMaybe (fmap fst . (\r -> takeAddress t0 r allowed b)) [0 .. 99]))
+
 -- | When an address can be tried again, if it is waiting.
 retryAt :: Int -> AddressBook Int -> Maybe UTCTime
 retryAt a b = case addressState a b of
@@ -38,7 +51,7 @@
 -- | Transitions applied to a few addresses at increasing times.
 data Op
   = Add Source Int
-  | Take NominalDiffTime
+  | Take NominalDiffTime Word64
   | Give Int
   | Connected Int
   | Finish NominalDiffTime Outcome Int
@@ -47,8 +60,8 @@
 instance Arbitrary Op where
   arbitrary =
     oneof
-      [ Add <$> elements [Configured, Discovered] <*> addr,
-        Take <$> time,
+      [ Add <$> elements [Configured, Seeded, Discovered] <*> addr,
+        Take <$> time <*> arbitrary,
         Give <$> addr,
         Connected <$> addr,
         Finish <$> time <*> elements [Disconnected, Failed, Misbehaved] <*> addr
@@ -60,7 +73,7 @@
 apply :: AddressBook Int -> Op -> AddressBook Int
 apply b = \case
   Add src a -> addAddress src a b
-  Take d -> maybe b snd (takeAddress (later d) b)
+  Take d r -> maybe b snd (takeAddress (later d) r (const True) b)
   Give a -> returnAddress a b
   Connected a -> markConnected a b
   Finish d o a -> finishAddress (later d) o a b
@@ -71,7 +84,7 @@
     let (a, b) = taken t0 (book [1])
     a `shouldBe` 1
     addressState 1 b `shouldBe` Just InUse
-    takeAddress t0 b `shouldSatisfy` isNothing
+    takeAny t0 b `shouldSatisfy` isNothing
 
   it "takes back an address that was not used" $ do
     let (_, b) = taken t0 (book [1])
@@ -80,8 +93,8 @@
   it "waits briefly later a normal disconnection" $ do
     let b = cycleWith Disconnected 1 (book [1])
     retryAt 1 b `shouldBe` Just (later retryDelay)
-    takeAddress t0 b `shouldSatisfy` isNothing
-    takeAddress (later retryDelay) b `shouldSatisfy` isJust
+    takeAny t0 b `shouldSatisfy` isNothing
+    takeAny (later retryDelay) b `shouldSatisfy` isJust
 
   it "doubles the wait later each failure, up to a limit" $ do
     let waits = map (retryAt 1) (drop 1 (iterate (cycleFailed 1) (book [1])))
@@ -105,9 +118,48 @@
   it "keeps a bounded number of discovered addresses" $ do
     let b = book [1 .. maxDiscovered + 10]
         b' = addAddress Configured (maxDiscovered + 20) b
-    length (knownAddresses b) `shouldBe` maxDiscovered
-    length (knownAddresses b') `shouldBe` maxDiscovered + 1
+    length (knownAddresses b) `shouldBe` 4096
+    length (knownAddresses b') `shouldBe` 4096 + 1
 
+  it "keeps a bounded number of seed addresses" $ do
+    let b = foldl' (flip (addAddress Seeded)) emptyBook [1 .. 4106 :: Int]
+    length (knownAddresses b) `shouldBe` 4096
+
+  it "learns a new seed address when gossip has filled the book" $ do
+    let b = addAddress Seeded 99999 (book [1 .. 4096])
+    addressState 99999 b `shouldBe` Just Ready
+
+  it "replaces a gossiped address that failed when the book is full" $ do
+    let b = addAddress Discovered 5000 (cycleWith Failed 7 (book [1 .. 4096]))
+    addressState 5000 b `shouldBe` Just Ready
+    addressState 7 b `shouldBe` Nothing
+    length (knownAddresses b) `shouldBe` 4096
+
+  it "keeps gossiped addresses that have not failed when the book is full" $ do
+    let b = addAddress Discovered 5000 (book [1 .. 4096])
+    addressState 5000 b `shouldBe` Nothing
+    length (knownAddresses b) `shouldBe` 4096
+
+  describe "choice" $ do
+    it "takes a configured address before any other" $ do
+      let b = addAddress Configured 9 (book [1 .. 5])
+      fmap fst (takeAddress t0 3 (const True) b) `shouldBe` Just 9
+
+    it "takes only addresses that the predicate allows" $
+      picks even (book [1 .. 10]) `shouldBe` [2, 4, 6, 8, 10]
+
+    it "takes nothing when the predicate allows no address" $
+      takeAddress t0 0 (const False) (book [1 .. 10]) `shouldSatisfy` isNothing
+
+    it "can take any address, whatever its port" $ do
+      -- 20 addresses on port 8333 and 8 on one host with lower ports. Taking
+      -- them in the order of the map would always start with the low ports.
+      let v4 a p = SockAddrInet p (tupleToHostAddress a)
+          honest = [v4 (8, 8, 8, fromIntegral i) 8333 | i <- [1 .. 20 :: Int]]
+          attacker = [v4 (45, 1, 2, 3) p | p <- [1000 .. 1007]]
+          b = foldl' (flip (addAddress Discovered)) emptyBook (honest <> attacker)
+      picks (const True) b `shouldBe` sort (honest <> attacker)
+
   describe "loading" $ do
     it "loads when the book is empty" $
       needsReload t0 (emptyBook :: AddressBook Int) `shouldBe` True
@@ -124,7 +176,7 @@
   prop "only hands out addresses that can be tried" $ \(ops :: [Op]) (d :: Int) ->
     let b = foldl' apply emptyBook ops
         now = later (fromIntegral (abs d))
-     in case takeAddress now b of
+     in case takeAny now b of
           Nothing -> property True
           Just (a, b') ->
             let ok = case addressState a b of
@@ -133,7 +185,25 @@
                   _ -> False
              in ok .&&. addressState a b' === Just InUse
 
-  prop "never forgets an address" $ \(ops :: [Op]) ->
+  -- Four addresses never fill the book, so none has to make room.
+  prop "never forgets an address while the book has room" $ \(ops :: [Op]) ->
     let b = foldl' apply emptyBook ops
         added = [a | Add _ a <- ops]
      in all (\a -> isJust (addressState a b)) added
+
+  prop "never keeps more than 4096 gossiped or 4096 seed addresses" $
+    forAll (listOf manyAddresses) $ \ops ->
+      let b = foldl' apply (book [1 .. 4096]) ops
+          from src = [a | a <- knownAddresses b, addressSource a b == Just src]
+       in length (from Discovered) <= 4096 .&&. length (from Seeded) <= 4096
+  where
+    -- Operations on 6000 addresses, on top of a book that is full already.
+    manyAddresses =
+      oneof
+        [ Add <$> elements [Seeded, Discovered] <*> chooseInt (1, 6000),
+          Take <$> (fromIntegral <$> chooseInt (0, 100000)) <*> arbitrary,
+          Finish
+            <$> (fromIntegral <$> chooseInt (0, 100000))
+            <*> elements [Disconnected, Failed, Misbehaved]
+            <*> chooseInt (1, 6000)
+        ]
diff --git a/test/unit/Haskoin/Node/PeerMgr/HandshakeSpec.hs b/test/unit/Haskoin/Node/PeerMgr/HandshakeSpec.hs
--- a/test/unit/Haskoin/Node/PeerMgr/HandshakeSpec.hs
+++ b/test/unit/Haskoin/Node/PeerMgr/HandshakeSpec.hs
@@ -10,9 +10,11 @@
 import Test.Hspec.QuickCheck (prop)
 import Test.QuickCheck
 
--- | Version of a full node with nonce 7.
+-- | Version of a full node with nonce 7. It offers the full chain and
+-- witness data: NODE_NETWORK (1) + NODE_WITNESS (8) = 9, as Bitcoin Core
+-- does.
 version :: Version
-version = versionWith nodeNetwork
+version = versionWith 9
 
 versionWith :: Word64 -> Version
 versionWith services =
@@ -86,10 +88,15 @@
 
   describe "version checks" $ do
     it "accepts a full node" $
-      checkVersion [1, 2] version `shouldBe` Right version
+      checkVersion btcRegTest [1, 2] version `shouldBe` Right version
     it "rejects a peer that does not serve blocks" $
-      checkVersion [] (versionWith 0) `shouldBe` Left NotFullNode
+      checkVersion btcRegTest [] (versionWith 0) `shouldBe` Left NotFullNode
+    it "rejects a Bitcoin peer that serves blocks without witness data" $
+      -- NODE_NETWORK (1) without NODE_WITNESS (8)
+      checkVersion btcRegTest [] (versionWith 1) `shouldBe` Left NotWitnessNode
+    it "accepts a Bitcoin Cash peer that serves blocks, which have no witness" $
+      checkVersion bchRegTest [] (versionWith 1) `shouldBe` Right (versionWith 1)
     it "rejects a connection to ourselves" $
-      checkVersion [7] version `shouldBe` Left ConnectedToSelf
+      checkVersion btcRegTest [7] version `shouldBe` Left ConnectedToSelf
     it "uses our protocol version" $
       version.version `shouldBe` fromIntegral myVersion
diff --git a/test/unit/Haskoin/Node/PeerMgr/LifecycleSpec.hs b/test/unit/Haskoin/Node/PeerMgr/LifecycleSpec.hs
--- a/test/unit/Haskoin/Node/PeerMgr/LifecycleSpec.hs
+++ b/test/unit/Haskoin/Node/PeerMgr/LifecycleSpec.hs
@@ -49,7 +49,7 @@
       <$> oneof
         [ Heard <$> time,
           GotHandshake <$> elements [GotVersion version, GotVerAck],
-          Refused <$> elements [NotFullNode, ConnectedToSelf],
+          Refused <$> elements [NotFullNode, NotWitnessNode, ConnectedToSelf],
           GotPong <$> time <*> nonce,
           Tick <$> time <*> nonce
         ]
@@ -125,6 +125,11 @@
     it "rotates a peer connected for too long" $
       drop 2 (snd (run (online <> [Heard (at 100), Tick (at 101) 1])))
         `shouldBe` [Disconnect TooOld]
+
+    it "keeps a peer connected for exactly its maximum life" $
+      -- 100 seconds is the maximum life here; the peer is pinged instead
+      drop 2 (snd (run (online <> [Heard (at 100), Tick (at 100) 1])))
+        `shouldBe` [SendPing 1]
 
     it "rotates before checking anything else" $
       snd (run [Tick (at 101) 1]) `shouldBe` [Disconnect TooOld]
diff --git a/test/unit/Haskoin/Node/PeerMgrSpec.hs b/test/unit/Haskoin/Node/PeerMgrSpec.hs
--- a/test/unit/Haskoin/Node/PeerMgrSpec.hs
+++ b/test/unit/Haskoin/Node/PeerMgrSpec.hs
@@ -171,6 +171,11 @@
                 Just (MVersion _) <- remoteReceive r
                 remoteSend r MVerAck
                 Just MVerAck <- remoteReceive r
+                -- The chain asks for headers once the peer is announced, so
+                -- closing after that request cannot beat the announcement.
+                remoteReceiveMatch 10 "header request" r $ \case
+                  MGetHeaders _ -> Just ()
+                  _ -> Nothing
                 return () -- close the connection
             | otherwise = honestRemote blocks r
       withScriptedNode net id script $ \t -> do
diff --git a/test/unit/Haskoin/Node/PeerSpec.hs b/test/unit/Haskoin/Node/PeerSpec.hs
--- a/test/unit/Haskoin/Node/PeerSpec.hs
+++ b/test/unit/Haskoin/Node/PeerSpec.hs
@@ -2,9 +2,11 @@
 module Haskoin.Node.PeerSpec (spec) where
 
 import Control.Concurrent.Async (ExceptionInLinkedThread (..))
-import Control.Monad (forM_)
+import Conduit (sinkNull, yieldMany)
+import Control.Monad (forM_, forever)
 import Data.ByteString qualified as B
 import Data.Serialize (putWord32le, runPut)
+import Data.Int (Int64)
 import Data.Word (Word32)
 import Haskoin
 import Haskoin.Node
@@ -17,6 +19,7 @@
 import Test.QuickCheck (Positive (..), ioProperty)
 import UnliftIO
 import UnliftIO.Concurrent (threadDelay)
+import System.Mem (getAllocationCounter)
 
 data PeerTest = PeerTest
   { peer :: !Peer,
@@ -25,12 +28,28 @@
     thread :: !(Async ())
   }
 
--- | Run a peer process connected to a remote that the test drives.
+-- | Run a peer process connected to a remote that the test drives. The peer
+-- knows no block headers.
 withPeerTest :: Network -> (PeerTest -> IO a) -> IO a
-withPeerTest net f = do
+withPeerTest net = withPeerTestKnowing net []
+
+-- | Run a peer process that knows blocks with the given hashes at the given
+-- heights, as if the node had stored their headers. Only the height of a
+-- known block matters to the peer, so the header in its node is a stand-in.
+withPeerTestKnowing ::
+  Network -> [(BlockHash, BlockHeight)] -> (PeerTest -> IO a) -> IO a
+withPeerTestKnowing net known f = do
   rv <- newEmptyMVar
   let script r = putMVar rv r >> forever_wait
       forever_wait = threadDelay maxBound >> forever_wait
+      lookup_block h = return (node_at <$> lookup h known)
+      node_at height =
+        BlockNode
+          { header = net.genesisHeader,
+            height = height,
+            work = 0,
+            skip = headerHash net.genesisHeader
+          }
   withTestLogger $ \logger ->
     withPublisher $ \pub ->
       withSubscription pub $ \events -> do
@@ -43,7 +62,8 @@
                   net = net,
                   label = "remote",
                   connect = memoryConnection net script,
-                  logger = logger
+                  logger = logger,
+                  lookupBlock = lookup_block
                 }
             p = wrapPeer cfg busy pending mailbox
         withAsync (peer cfg p inbox) $ \thread -> do
@@ -85,6 +105,41 @@
     Nothing -> return ()
     Just r -> assertFailure $ "Peer process stopped: " <> show r
 
+-- | Bytes allocated by a peer process to read one message of the given
+-- payload size on Bitcoin, sent in pieces of 1460 bytes, the payload of a
+-- full TCP segment. The counter is read in the thread that reads the
+-- message, before the first piece and once the message has been passed on.
+readAllocation :: Int -> IO Int64
+readAllocation size = do
+  let bs = encodeMessage btc (MOther "zz" (B.replicate size 0))
+      pieces = chunks (repeat 1460) bs
+  _ <- evaluate (sum (map B.length pieces))
+  start <- newEmptyMVar
+  end <- newEmptyMVar
+  let src = do
+        liftIO (getAllocationCounter >>= putMVar start)
+        yieldMany pieces
+        liftIO (getAllocationCounter >>= putMVar end)
+        liftIO (forever (threadDelay maxBound))
+  withTestLogger $ \logger -> withPublisher $ \pub -> do
+    (inbox, mailbox) <- newMailbox
+    busy <- newTVarIO Free
+    pending <- newTVarIO 0
+    let cfg =
+          PeerConfig
+            { pub = pub,
+              net = btc,
+              label = "remote",
+              connect = \f -> f (Conduits src sinkNull),
+              logger = logger,
+              lookupBlock = \_ -> return Nothing
+            }
+    withAsync (peer cfg (wrapPeer cfg busy pending mailbox) inbox) $ \_ -> do
+      counter0 <- within 30 "first piece" (readMVar start)
+      counter1 <- within 30 "message read" (readMVar end)
+      -- the counter goes down as the thread allocates
+      return (counter0 - counter1)
+
 -- | Chop a byte string into pieces of the given sizes.
 chunks :: [Int] -> B.ByteString -> [B.ByteString]
 chunks _ b | B.null b = []
@@ -95,6 +150,21 @@
 withLength :: Word32 -> B.ByteString -> B.ByteString
 withLength len bs = B.take 16 bs <> runPut (putWord32le len) <> B.drop 20 bs
 
+-- | A version message with a user agent of the given length.
+withUserAgent :: Int -> Version -> Version
+withUserAgent n v =
+  Version
+    { version = v.version,
+      services = v.services,
+      timestamp = v.timestamp,
+      addrRecv = v.addrRecv,
+      addrSend = v.addrSend,
+      nonce = v.nonce,
+      userAgent = VarString (B.replicate n 0x61),
+      startHeight = v.startHeight,
+      relay = v.relay
+    }
+
 spec :: Spec
 spec = do
   let net = btcRegTest
@@ -105,6 +175,9 @@
       bhash b = headerHash b.header
       block_iv :: Block -> InvVector
       block_iv b = InvVector InvWitnessBlock (bhash b).get
+      -- the parent of 'coreSegWitBlock', block 301 of its chain
+      parent302 = "7bd5bfebea6d3194d92f9f292bc57d82c884f72c53bb11f529c8973fb63e52b9"
+      stripped b = b {txs = [tx {witness = []} | tx <- b.txs]}
   describe "peer message framing" $ do
     it "parses messages split across arbitrary chunks" $
       withPeerTest net $ \t -> do
@@ -136,6 +209,29 @@
       MPing (Ping 9) `sendMessage` t.peer
       remoteReceiveMatch 5 "ping" t.remote Just `shouldReturn` MPing (Ping 9)
 
+  describe "peer reading" $ do
+    it "allocates in proportion to the size of a message sent in 1460-byte pieces" $ do
+      -- Reading should cost memory linear in the size of the message, as in
+      -- Bitcoin Core, which reads into one buffer. Twice the size should then
+      -- cost about twice the allocation; a cost that grows with the square of
+      -- the size would cost about four times. 4,000,000 bytes is the largest
+      -- message Bitcoin allows.
+      small <- readAllocation 2000000
+      large <- readAllocation 4000000
+      fromIntegral large / fromIntegral small `shouldSatisfy` (< (2.5 :: Double))
+
+    it "stops reading a peer that has 16 messages waiting to be handled" $
+      withPeerTest net $ \t -> do
+        -- The node keeps at most 16 messages from a peer waiting.
+        forM_ [1 .. 20] $ \i -> remoteSend t.remote (MPing (Ping i))
+        got <- mapM (const (received t)) [1 .. 16 :: Int]
+        got `shouldBe` [MPing (Ping i) | i <- [1 .. 16]]
+        expectNothingWithin 1 "a 17th message" t.events $ \case
+          PeerMessage _ _ -> Just ()
+          _ -> Nothing
+        peerMessageDone t.peer
+        received t `shouldReturn` MPing (Ping 17)
+
   describe "peer protocol violations" $ do
     it "disconnects on wrong network magic" $ withPeerTest net $ \t -> do
       remoteSendRaw t.remote (encodeMessage btc (MPing (Ping 1)))
@@ -168,6 +264,59 @@
         InvalidPayload MCPing _ -> True
         _ -> False
 
+    it "disconnects a peer that announces a message over 4,000,000 bytes on Bitcoin" $
+      withPeerTest btc $ \t -> do
+        -- Bitcoin Core: MAX_PROTOCOL_MESSAGE_LENGTH = 4,000,000. Only the
+        -- header is sent.
+        let bs = encodeMessage btc (MTx (coinbaseTx 0 0))
+        remoteSendRaw t.remote (B.take 24 (withLength 4000001 bs))
+        expectFailure t $ \case
+          MessageTooLarge MCTx 4000001 -> True
+          _ -> False
+
+    it "disconnects a peer that sends an inventory of 50,001 items" $
+      withPeerTest net $ \t -> do
+        -- Bitcoin Core: MAX_INV_SZ = 50,000
+        remoteSend t.remote (MInv (Inv (replicate 50001 (block_iv b0))))
+        expectFailure t $ \case
+          InvalidPayload MCInv _ -> True
+          _ -> False
+
+    it "accepts an inventory of 50,000 items" $ withPeerTest net $ \t -> do
+      remoteSend t.remote (MInv (Inv (replicate 50000 (block_iv b0))))
+      received t >>= \case
+        MInv (Inv ivs) -> length ivs `shouldBe` 50000
+        m -> assertFailure ("Unexpected message: " <> show (msgType m))
+
+    it "disconnects a peer that sends a locator of 102 hashes" $
+      withPeerTest net $ \t -> do
+        -- Bitcoin Core: MAX_LOCATOR_SZ = 101
+        let gh = GetHeaders {version = 70012, locator = replicate 102 (bhash b0), stop = bhash b0}
+        remoteSend t.remote (MGetHeaders gh)
+        expectFailure t $ \case
+          InvalidPayload MCGetHeaders _ -> True
+          _ -> False
+
+    it "accepts a locator of 101 hashes" $ withPeerTest net $ \t -> do
+      let gh = GetHeaders {version = 70012, locator = replicate 101 (bhash b0), stop = bhash b0}
+      remoteSend t.remote (MGetHeaders gh)
+      received t `shouldReturn` MGetHeaders gh
+
+    it "disconnects a peer whose user agent is 257 bytes long" $
+      withPeerTest net $ \t -> do
+        -- Bitcoin Core: MAX_SUBVERSION_LENGTH = 256
+        v <- remoteVersion net nodeNetwork 1
+        remoteSend t.remote (MVersion (withUserAgent 257 v))
+        expectFailure t $ \case
+          InvalidPayload MCVersion _ -> True
+          _ -> False
+
+    it "accepts a user agent of 256 bytes" $ withPeerTest net $ \t -> do
+      v <- remoteVersion net nodeNetwork 1
+      let v' = withUserAgent 256 v
+      remoteSend t.remote (MVersion v')
+      received t `shouldReturn` MVersion v'
+
     it "disconnects when the remote closes the connection" $
       withPeerTest net $ \t -> do
         remoteClose t.remote
@@ -227,6 +376,59 @@
     it "times out when the peer does not answer" $
       withPeerTest net $ \t ->
         getBlocks net 1 t.peer [bhash b0] `shouldReturn` Nothing
+
+    it "gives nothing and drops a peer whose block does not match its header" $
+      withPeerTest net $ \t -> do
+        let forged = Block {header = b0.header, txs = [coinbaseTx 99 7]}
+            f = \case
+              MGetData _ -> [MBlock forged]
+              m -> pong m
+        serve t f $ getBlocks net 2 t.peer [bhash b0] `shouldReturn` Nothing
+        expectFailure t $ \case
+          MutatedBlock h BadMerkleRoot -> h == bhash b0
+          _ -> False
+
+    it "returns a SegWit block that Bitcoin Core mined, with its witness" $
+      withPeerTestKnowing net [(parent302, 301)] $ \t -> do
+        let f = \case
+              MGetData _ -> [MBlock coreSegWitBlock]
+              m -> pong m
+        serve t f $
+          getBlocks net 5 t.peer [bhash coreSegWitBlock]
+            `shouldReturn` Just [coreSegWitBlock]
+
+    it "gives nothing and drops a peer that stripped the witness of a SegWit block" $
+      withPeerTestKnowing net [(parent302, 301)] $ \t -> do
+        let f = \case
+              MGetData _ -> [MBlock (stripped coreSegWitBlock)]
+              m -> pong m
+        serve t f $ getBlocks net 2 t.peer [bhash coreSegWitBlock] `shouldReturn` Nothing
+        expectFailure t $ \case
+          MutatedBlock _ BadWitnessNonceSize -> True
+          _ -> False
+
+    it "gives nothing and drops a peer that repeats the last transaction of a block" $
+      withPeerTestKnowing net [(parent302, 301)] $ \t -> do
+        -- CVE-2012-2459: the repeated transaction keeps the Merkle root.
+        let b = coreSegWitBlock {txs = coreSegWitBlock.txs <> drop 2 coreSegWitBlock.txs}
+            f = \case
+              MGetData _ -> [MBlock b]
+              m -> pong m
+        serve t f $ getBlocks net 2 t.peer [bhash coreSegWitBlock] `shouldReturn` Nothing
+        expectFailure t $ \case
+          MutatedBlock _ DuplicateTransactions -> True
+          _ -> False
+
+    it "does not check the witness of a block whose parent it does not know" $
+      withPeerTest net $ \t -> do
+        -- Bitcoin Core does not check it either: without the parent, the
+        -- height and so the witness rule are unknown.
+        let f = \case
+              MGetData _ -> [MBlock (stripped coreSegWitBlock)]
+              m -> pong m
+        serve t f $
+          getBlocks net 5 t.peer [bhash coreSegWitBlock]
+            `shouldReturn` Just [stripped coreSegWitBlock]
 
     it "downloads transactions" $ withPeerTest net $ \t -> do
       let txs = concatMap (.txs) blocks
diff --git a/test/unit/Haskoin/NodeSpec.hs b/test/unit/Haskoin/NodeSpec.hs
--- a/test/unit/Haskoin/NodeSpec.hs
+++ b/test/unit/Haskoin/NodeSpec.hs
@@ -27,7 +27,9 @@
 import Haskoin
 import Haskoin.Node
 import NQE
-import Network.Socket (SockAddr (..), tupleToHostAddress, tupleToHostAddress6)
+import Data.Word (Word32, Word8)
+import Haskoin.Node.Test (eventually)
+import Network.Socket (PortNumber, SockAddr (..), tupleToHostAddress, tupleToHostAddress6)
 import System.Random (randomIO)
 import Test.Hspec
 import UnliftIO
@@ -39,7 +41,9 @@
     nodeEvents :: Inbox NodeEvent,
     testDB :: R.DB,
     -- | how many getheaders messages the mock peer has received
-    getHeadersCount :: TVar Int
+    getHeadersCount :: TVar Int,
+    -- | every address the node tried to connect to, newest first
+    attempts :: TVar [SockAddr]
   }
 
 -- | What the mock peer sends back for each message: a message to serialize
@@ -51,7 +55,11 @@
   { react :: React,
     -- | runs on the database before the node starts
     setup :: R.DB -> IO (),
-    timeout :: NominalDiffTime
+    timeout :: NominalDiffTime,
+    -- | connect to seeds and relayed addresses
+    discover :: Bool,
+    -- | the static peers of the configuration
+    staticPeers :: [String]
   }
 
 defOpts :: [Block] -> TestOpts
@@ -59,7 +67,10 @@
   TestOpts
     { react = map Right . mockPeerReact blocks,
       setup = \_ -> return (),
-      timeout = 120
+      timeout = 120,
+      discover = False,
+      -- IPv4, so that the mock peer is reachable without IPv6
+      staticPeers = ["127.0.0.1:17486"]
     }
 
 -- | Connect to a mock peer that reacts to messages like this.
@@ -155,8 +166,11 @@
       -- while every other message is limited to 2 MiB (2097152 bytes).
       let script = B.replicate 3000000 0x6a
           tx = Tx 1 [TxIn nullOutPoint B.empty maxBound] [TxOut 0 script] [] 0
+          -- a header that commits to the transaction, or the node would
+          -- refuse the block as not the one its header names
+          root = either error id (buildMerkleRoot [txHash tx])
           big = case allBlocks of
-            firstBlock : _ -> Block firstBlock.header [tx]
+            firstBlock : _ -> Block firstBlock.header {merkle = root} [tx]
             [] -> error "no test blocks"
       withTestNodeBlocks [big] net "big-block" $ \TestNode {..} -> do
         p <- waitForPeer nodeEvents
@@ -174,7 +188,7 @@
   describe "untrusted peers" $ do
     it "imports a full batch of 2000 headers"
       $ withTestNodeOpts
-        (defOpts allBlocks) {react = reactAfterVerAck [Right (manyHeaders net 2000)]}
+        (defOpts allBlocks) {react = reactWhenOnline [Right (manyHeaders net 2000)]}
         net
         "full-batch"
       $ \TestNode {..} -> do
@@ -185,7 +199,7 @@
         bn.height `shouldBe` 2000
     it "disconnects a peer that sends more than 2000 headers"
       $ withTestNodeOpts
-        (defOpts allBlocks) {react = reactAfterVerAck [Right (manyHeaders net 2001)]}
+        (defOpts allBlocks) {react = reactWhenOnline [Right (manyHeaders net 2001)]}
         net
         "too-many-headers"
       $ \TestNode {..} -> do
@@ -196,7 +210,7 @@
       let na = NetworkAddress 0 (sockToHostAddress (SockAddrInet 8333 0x08080808))
           addrs = MAddr (Addr (replicate 1001 (0, na)))
       withTestNodeOpts
-        (defOpts allBlocks) {react = reactAfterVerAck [Right addrs]}
+        (defOpts allBlocks) {react = reactWhenOnline [Right addrs]}
         net
         "too-many-addrs"
         $ \TestNode {..} -> do
@@ -205,7 +219,7 @@
     it "disconnects a peer that sends the wrong network magic" $ do
       let bad = runPut (putMessage btc (MPing (Ping 1)))
       withTestNodeOpts
-        (defOpts allBlocks) {react = reactAfterVerAck [Left bad]}
+        (defOpts allBlocks) {react = reactWhenOnline [Left bad]}
         net
         "wrong-magic"
         $ \TestNode {..} -> do
@@ -219,7 +233,7 @@
             runPut . put $
               MessageHeader net.magic MCTx 2097153 (checkSum32 B.empty)
       withTestNodeOpts
-        (defOpts allBlocks) {react = reactAfterVerAck [Left oversized]}
+        (defOpts allBlocks) {react = reactWhenOnline [Left oversized]}
         net
         "oversized-tx"
         $ \TestNode {..} -> do
@@ -227,7 +241,7 @@
           waitForDisconnect nodeEvents p
     it "disconnects a peer that sends a second verack"
       $ withTestNodeOpts
-        (defOpts allBlocks) {react = reactAfterVerAck [Right MVerAck]}
+        (defOpts allBlocks) {react = reactWhenOnline [Right MVerAck]}
         net
         "duplicate-verack"
       $ \TestNode {..} -> do
@@ -261,6 +275,68 @@
         $ \TestNode {..} -> do
           p <- waitForPeer nodeEvents
           waitForDisconnect nodeEvents p
+    it "publishes no message from a peer that has not completed the handshake" $ do
+      -- The mock peer sends its version, then a message instead of a verack.
+      let react = \case
+            MVersion _ -> [Right (MOther "zz" "early")]
+            _ -> []
+      withTestNodeOpts (defOpts allBlocks) {react = react} net "early-message" $
+        \TestNode {..} -> do
+          -- the version is the handshake itself, and is published
+          receiveMatch nodeEvents $ \case
+            PeerEvent (PeerMessage _ (MVersion _)) -> Just ()
+            _ -> Nothing
+          early <- timeout (2 * 1000 * 1000) . receiveMatch nodeEvents $ \case
+            PeerEvent (PeerMessage _ (MOther "zz" _)) -> Just ()
+            _ -> Nothing
+          early `shouldBe` Nothing
+    it "publishes the messages of a peer that is online" $ do
+      let react = reactWhenOnline [Right (MOther "zz" "late")]
+      withTestNodeOpts (defOpts allBlocks) {react = react} net "late-message" $
+        \TestNode {..} -> do
+          late <- timeout (10 * 1000 * 1000) . receiveMatch nodeEvents $ \case
+            PeerEvent (PeerMessage _ (MOther "zz" payload)) -> Just payload
+            _ -> Nothing
+          late `shouldBe` Just "late"
+    it "does not connect to a private address that an online peer relays" $ do
+      let private = v4At (10, 1, 2, 3) 8333
+          public = v4At (8, 8, 4, 4) 8333
+          relay = MAddr (Addr [relayed private, relayed public])
+      withTestNodeOpts
+        (defOpts allBlocks) {react = reactWhenOnline [Right relay], discover = True}
+        net
+        "relay-private"
+        $ \TestNode {..} -> do
+          -- the public address shows that the relayed addresses were learned
+          eventually 30 "public address tried" $ elem public <$> readTVarIO attempts
+          -- the node tries a new address every 0.1 to 5 seconds
+          threadDelay (6 * 1000 * 1000)
+          readTVarIO attempts >>= (`shouldNotContain` [private])
+    it "connects to at most one relayed address of each network group" $ do
+      let sameGroup = [v4At (45, 1, 2, 3) p | p <- [1000 .. 1015]]
+          others = [v4At (46, 1, 0, 1) 8333, v4At (47, 2, 0, 1) 8333]
+          relay = MAddr (Addr (map relayed (sameGroup <> others)))
+      withTestNodeOpts
+        (defOpts allBlocks) {react = reactWhenOnline [Right relay], discover = True}
+        net
+        "relay-same-group"
+        $ \TestNode {..} -> do
+          eventually 30 "addresses of the other groups tried" $
+            (\tried -> all (`elem` tried) others) <$> readTVarIO attempts
+          threadDelay (6 * 1000 * 1000)
+          tried <- readTVarIO attempts
+          length (filter (`elem` sameGroup) tried) `shouldBe` 1
+    it "does not connect to a DNS seed result that is not routable" $
+      -- The seed of regtest is localhost, which resolves to loopback
+      -- addresses. With no static peers, nothing else could be tried.
+      withTestNodeOpts
+        (defOpts allBlocks) {discover = True, staticPeers = []}
+        net
+        "seed-loopback"
+        $ \TestNode {..} -> do
+          -- the node tries a new address every 0.1 to 5 seconds
+          threadDelay (6 * 1000 * 1000)
+          readTVarIO attempts `shouldReturn` []
     it "does not connect to private addresses that peers relay" $ do
       let v4 a b c d p = SockAddrInet p (tupleToHostAddress (a, b, c, d))
           v6 t p = SockAddrInet6 p 0 (tupleToHostAddress6 t) 0
@@ -362,6 +438,14 @@
         forM_ (zip ps hs) $ \(p, h) ->
           headerHash p.header `shouldBe` h
 
+-- | An IPv4 socket address.
+v4At :: (Word8, Word8, Word8, Word8) -> PortNumber -> SockAddr
+v4At a p = SockAddrInet p (tupleToHostAddress a)
+
+-- | An address as a peer relays it in an addr message.
+relayed :: SockAddr -> (Word32, NetworkAddress)
+relayed sa = (0, NetworkAddress nodeNetwork (sockToHostAddress sa))
+
 -- | Wait for the node to disconnect from this peer, failing after a while.
 waitForDisconnect :: Inbox NodeEvent -> Peer -> IO ()
 waitForDisconnect inbox p =
@@ -374,11 +458,16 @@
         PeerEvent (PeerDisconnected p') | p == p' -> Just ()
         _ -> Nothing
 
--- | Mock peer that answers the handshake and pings, and sends these right
--- after its version ack.
-reactAfterVerAck :: [Either ByteString Message] -> React
-reactAfterVerAck extra = \case
-  MVersion _ -> Right MVerAck : extra
+-- | Mock peer that answers the handshake and pings, and sends these each
+-- time the node asks it for headers. The chain asks only once the peer is
+-- announced as connected, so the messages cannot overtake the announcement.
+-- Sent right after the verack, they raced with it: a peer that misbehaved at
+-- once could die before the node handled its verack, and was then never
+-- announced.
+reactWhenOnline :: [Either ByteString Message] -> React
+reactWhenOnline extra = \case
+  MVersion _ -> [Right MVerAck]
+  MGetHeaders _ -> extra
   MPing (Ping n) -> [Right (MPong (Pong n))]
   _ -> []
 
@@ -402,11 +491,17 @@
       0
       genesis {version = 4, prev = headerHash genesis, timestamp = now}
 
+-- | Wait for a peer to be announced, failing after a while.
 waitForPeer :: Inbox NodeEvent -> IO Peer
 waitForPeer inbox =
-  receiveMatch inbox $ \case
-    PeerEvent (PeerConnected p) -> Just p
-    _ -> Nothing
+  timeout (30 * 1000 * 1000) connected >>= \case
+    Just p -> return p
+    Nothing -> expectationFailure "no peer connected" >> error "unreachable"
+  where
+    connected =
+      receiveMatch inbox $ \case
+        PeerEvent (PeerConnected p) -> Just p
+        _ -> Nothing
 
 withLifted :: ((a -> IO b) -> IO b) -> (a -> IO b) -> IO b
 withLifted w m = withRunInIO $ \io -> w (io . m)
@@ -428,36 +523,40 @@
       withSubscription pub $ \sub ->
         withLifted (R.withDBCF w cfg cols) $ \db -> do
           count <- newTVarIO 0
+          tried <- newTVarIO []
           opts.setup db
-          withNode (nodeConfig count pub db) $ \(Node mgr ch) ->
+          withNode (nodeConfig count tried pub db) $ \(Node mgr ch) ->
             f
               TestNode
                 { testMgr = mgr,
                   testChain = ch,
                   nodeEvents = sub,
                   testDB = db,
-                  getHeadersCount = count
+                  getHeadersCount = count,
+                  attempts = tried
                 }
   where
-    nodeConfig count pub db =
+    nodeConfig count tried pub db =
       NodeConfig
         { maxPeers = 20,
           db = db,
           cf = listToMaybe (R.columnFamilies db),
-          -- IPv4, so that the mock peer is reachable without IPv6
-          peers = ["127.0.0.1:17486"],
-          discover = False,
+          peers = opts.staticPeers,
+          discover = opts.discover,
           address = NetworkAddress 0 anywhere,
           net = net,
           pub = pub,
           timeout = opts.timeout,
           maxPeerLife = 48 * 3600,
-          connect =
+          connect = \sa conn -> do
+            atomically $ modifyTVar' tried (sa :)
             dummyPeerConnect
               opts.react
               count
               net
-              (NetworkAddress nodeNetwork anywhere),
+              (NetworkAddress nodeNetwork anywhere)
+              sa
+              conn,
           logger = Logger {level = LevelError, source = "", push = \_ -> return ()}
         }
     anywhere = sockToHostAddress (SockAddrInet 0 0)