haskoin-node 2.4.0 → 2.5.0

raw patch · 27 files changed

+2045/−240 lines, 27 filesdep +streaming-commonsdep ~rocksdb-haskell-jpruppdep ~textPVP ok

version bump matches the API change (PVP)

Dependencies added: streaming-commons

Dependency ranges changed: rocksdb-haskell-jprupp, text

API changes (from Hackage documentation)

Files

• CHANGELOG.md +117/−0
• README.md +112/−34
• haskoin-node.cabal +11/−3
• src/Haskoin/Node.hs +44/−18
• src/Haskoin/Node/Address.hs +112/−22
• src/Haskoin/Node/Block.hs +223/−0
• src/Haskoin/Node/Chain.hs +71/−12
• src/Haskoin/Node/Chain/Sync.hs +104/−11
• src/Haskoin/Node/Peer.hs +69/−11
• src/Haskoin/Node/Peer/Request.hs +6/−0
• src/Haskoin/Node/PeerMgr.hs +46/−15
• src/Haskoin/Node/PeerMgr/Addresses.hs +136/−25
• src/Haskoin/Node/PeerMgr/Handshake.hs +15/−8
• test/common/Haskoin/Node/Test.hs +61/−1
• test/regtest/Containerfile +9/−23
• test/regtest/Regtest/Podman.hs +2/−1
• test/regtest/install-nodes.sh +61/−0
• test/unit/Haskoin/Node/AddressSpec.hs +110/−1
• test/unit/Haskoin/Node/BlockSpec.hs +170/−0
• test/unit/Haskoin/Node/Chain/SyncSpec.hs +49/−2
• test/unit/Haskoin/Node/ChainSpec.hs +77/−1
• test/unit/Haskoin/Node/PeerMgr/AddressesSpec.hs +85/−15
• test/unit/Haskoin/Node/PeerMgr/HandshakeSpec.hs +12/−5
• test/unit/Haskoin/Node/PeerMgr/LifecycleSpec.hs +6/−1
• test/unit/Haskoin/Node/PeerMgrSpec.hs +5/−0
• test/unit/Haskoin/Node/PeerSpec.hs +206/−4
• test/unit/Haskoin/NodeSpec.hs +126/−27

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

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

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

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

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

@@ -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 = []})

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

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

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

@@ -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 (..),

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

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

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

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

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

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

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

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

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

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

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

@@ -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)+        ]

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

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

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

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

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