diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -4,6 +4,16 @@ 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). +## [2.3.1] - 2026-11-07 + +### Changed + +- Documentation: the README explains the purpose and design of the node, with + installation steps, configuration, security notes and a tutorial, and the + Haddock of every module and function says why it works the way it does. +- Build against nqe 0.6.9, rocksdb-haskell-jprupp 2.6.1, rocksdb-query 0.6.1 + and Stackage nightly-2026-11-07. + ## [2.3.0] - 2026-11-06 ### Changed diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,5 +1,505 @@ # Haskoin Node -Haskoin Node is a peer-to-peer library for Bitcoin and Bitcoin Cash. It uses a -RocksDB database to store blockchain headers and peers. +[![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) +Haskoin Node is a peer-to-peer networking library for Bitcoin (BTC) and Bitcoin +Cash (BCH), written in Haskell. It connects to the network, keeps a pool of +healthy peers, and syncs block headers into a [RocksDB](https://rocksdb.org) +database. + +It does not download or validate blocks and transactions by itself. It +publishes everything that happens as events, and gives you the peers to ask for +the data you need. It is the networking layer of +[Haskoin Store](https://github.com/jprupp/haskoin-store). + +- [API documentation](https://hackage.haskell.org/package/haskoin-node) +- [Changelog](https://github.com/jprupp/haskoin-node/blob/master/CHANGELOG.md) +- [Report a bug](https://github.com/jprupp/haskoin-node/issues) + +## Contents + +- [Why Haskoin Node](#why-haskoin-node) +- [Design principles](#design-principles) +- [Features](#features) +- [Installation](#installation) +- [Quick start](#quick-start) +- [Tutorial: a block watcher](#tutorial-a-block-watcher) +- [Concepts](#concepts) +- [Usage guide](#usage-guide) +- [Configuration](#configuration) +- [Module overview](#module-overview) +- [Security notes](#security-notes) +- [Development](#development) +- [Related projects](#related-projects) +- [License](#license) + +## Why Haskoin Node + +A program that wants Bitcoin data has two usual options. It can run a full node +such as Bitcoin Core next to it and talk to its RPC interface, which means +operating a second large piece of software. Or it can speak the peer-to-peer +protocol itself, which means solving the same problems every node solves: +finding peers, keeping good ones, dropping bad ones, parsing untrusted +messages safely, and following the header chain through reorganisations. + +Haskoin Node solves those problems once, as a library. It gives a Haskell +program a direct, well-behaved presence on the network, and stops there: what +to download, what to validate and what to store is up to the program. It is +the networking layer of [Haskoin Store](https://github.com/jprupp/haskoin-store), +which indexes the whole Bitcoin and Bitcoin Cash block chains this way without +a full node. + +## Design principles + +- **Do one job.** Keep connected and keep the header chain current. Blocks, + transactions, validation and storage of anything but headers belong to the + application, because every application wants something different. +- **Headers are the source of truth.** Headers are small (80 bytes) and carry + the proof of work. With them, the node knows which chain is real without + downloading blocks, and can tell the application which blocks to fetch. +- **Tell, don't ask.** Everything the node learns becomes an event on a + 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. +- **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. +- **Small, isolated components.** The peer manager, the header chain and each + connection are separate [NQE](https://github.com/jprupp/nqe) processes with + their own state. One misbehaving peer dies alone. + +## Features + +| Area | What you get | +| --------------- | ---------------------------------------------------------------------------------------------- | +| 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 | +| Header sync | Headers downloaded from one peer at a time, connected to the chain with the most work, stored in RocksDB | +| 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 | + +### What is not included + +- No block or transaction validation, and no mempool. Haskoin Store does this + on top of the events. +- No inbound connections: the node only connects out. +- No compact blocks, Bloom filters (BIP-37) or compact block filters (BIP-157). + +## Installation + +### System libraries + +Haskoin Node needs [RocksDB](https://rocksdb.org) and +[libsecp256k1](https://github.com/bitcoin-core/secp256k1) 0.2.0 or later, with +`pkg-config` to find them. + +```sh +# Debian and Ubuntu +sudo apt-get install librocksdb-dev libsecp256k1-dev pkg-config + +# Fedora +sudo dnf install rocksdb-devel libsecp256k1-devel pkgconf + +# macOS with Homebrew +brew install rocksdb secp256k1 pkg-config + +# Nix +nix-shell -p rocksdb secp256k1 pkg-config +``` + +Some older distributions ship a libsecp256k1 below 0.2.0. See the +[haskoin-core installation notes](https://github.com/jprupp/haskoin-core#system-library) +for how to build it. + +### Check the libraries are found + +```sh +pkg-config --modversion libsecp256k1 # 0.2.0 or later +ls /usr/include/rocksdb/c.h # or $(brew --prefix)/include/rocksdb/c.h +``` + +### Compiler + +It needs GHC 9.2 or later, because it uses `OverloadedRecordDot`. It is built +and tested with the GHC of the Stackage nightly in `stack.yaml`. + +### With Cabal + +```cabal +build-depends: + base + , data-default + , haskoin-core + , haskoin-node + , nqe + , rocksdb-haskell-jprupp +``` + +You open the database with `rocksdb-haskell-jprupp` and create the event +publisher with `nqe`. + +### With Stack + +Recent Stackage nightly snapshots include Haskoin Node. With an older resolver, +add it and its dependencies to `stack.yaml`: + +```yaml +extra-deps: + - haskoin-node-2.3.1 + - haskoin-core-1.6.1 + - secp256k1-haskell-2.0.0 + - base16-2.0 + - rocksdb-haskell-jprupp-2.6.1 + - rocksdb-query-0.6.1 + - nqe-0.6.9 +``` + +### Step by step with Stack + +1. Install [Stack](https://docs.haskellstack.org/) and the libraries above. +2. Create a project: + + ```sh + stack new node-demo simple + cd node-demo + ``` + +3. Add the packages listed under [With Cabal](#with-cabal) to `build-depends` + in `node-demo.cabal`, plus `network`. +4. If your resolver is older than the packages, add the `extra-deps` shown + under [With Stack](#with-stack) to `stack.yaml`. +5. Put the [quick start](#quick-start) program in `src/Main.hs` and run it: + + ```sh + stack run + ``` + + Within a few seconds it logs connections and starts printing header + heights. A full header sync of Bitcoin usually takes minutes and on the + order of a hundred megabytes of disk; it resumes where it stopped if you + interrupt it. + +## Quick start + +This program connects to Bitcoin, syncs headers, and prints what happens: + +```haskell +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedRecordDot #-} + +import Control.Monad (forever) +import Data.Default (def) +import Database.RocksDB (Config (..), withDB) +import Haskoin (NetworkAddress (..), btc, sockToHostAddress) +import Haskoin.Node +import NQE (receive, withPublisher, withSubscription) +import Network.Socket (SockAddr (..)) + +main :: IO () +main = + withLogger LevelInfo $ \logger -> + withDB "/tmp/haskoin-node" def {createIfMissing = True} $ \db -> + withPublisher $ \pub -> + withSubscription pub $ \events -> do + let cfg = + NodeConfig + { maxPeers = 8, + db = db, + cf = Nothing, + peers = [], + discover = True, + address = NetworkAddress 0 (sockToHostAddress (SockAddrInet 0 0)), + net = btc, + pub = pub, + timeout = 120, + maxPeerLife = 48 * 3600, + connect = withConnection, + logger = logger + } + withNode cfg $ \_node -> forever $ + receive events >>= \case + ChainEvent (ChainBestBlock bn) -> + putStrLn ("Best header: " <> show bn.height) + ChainEvent (ChainSynced _) -> + putStrLn "Headers in sync" + PeerEvent (PeerConnected p) -> + putStrLn ("Connected: " <> show p) + _ -> return () +``` + +Subscribe to the publisher before calling `withNode`, as here, or you may miss +the first events. + +## Tutorial: a block watcher + +This builds a program that prints every new Bitcoin block with its number of +transactions. It shows the intended division of labour: the node follows +headers and tells you about them, and you fetch what you need. + +### 1. Wait until the headers are synced + +At start-up the node downloads hundreds of thousands of headers, each one a +`ChainBestBlock` event. Reacting to each of those would mean fetching every +historical block. Wait for `ChainSynced` first: + +```haskell +waitSynced :: Inbox NodeEvent -> IO () +waitSynced events = + receive events >>= \case + ChainEvent (ChainSynced _) -> return () + _ -> waitSynced events +``` + +### 2. React to new best headers + +After that, each `ChainBestBlock` is a new block at the tip, or the new tip +after a reorganisation: + +```haskell +watch :: Network -> Node -> Inbox NodeEvent -> IO () +watch net node events = forever $ + receive events >>= \case + ChainEvent (ChainBestBlock bn) -> fetch net node bn + _ -> return () +``` + +### 3. Fetch the block from the fastest peer + +`getPeers` lists online peers, fastest first. Ask one, and try the next if it +fails or times out: + +```haskell +fetch :: Network -> Node -> BlockNode -> IO () +fetch net node bn = getPeers node.peerMgr >>= go + where + hash = headerHash bn.header + go [] = putStrLn ("No peer could send block " <> show bn.height) + go (op : ops) = + getBlocks net 30 op.mailbox [hash] >>= \case + Just [b] -> + putStrLn (show bn.height <> ": " <> show (length b.txs) <> " transactions") + _ -> go ops +``` + +### 4. Put it together + +Use the configuration from the [quick start](#quick-start), and run the watcher +inside `withNode`: + +```haskell +withNode cfg $ \node -> do + waitSynced events + watch btc node events +``` + +### What the node did for you + +While this runs, the node keeps eight connections, measures and ranks them, +drops silent or misbehaving peers and finds replacements, stores headers so a +restart is quick, and switches to a heavier chain if one appears. The watcher is +only twenty lines because none of that is its concern. + +## Concepts + +### Components + +`withNode` starts two processes, built with [NQE](https://github.com/jprupp/nqe): + +- 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. +- 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. + +Each peer connection is its own process (`Haskoin.Node.Peer`), run by a +supervisor inside the peer manager. + +### Events + +Everything is published to the `Publisher NodeEvent` in the configuration: + +| Event | When | +| --------------------------------------- | ------------------------------------------------------- | +| `ChainEvent (ChainBestBlock node)` | The best header changed, including on start | +| `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 | + +"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. + +### Back-pressure + +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. + +### Database layout + +Headers are stored in the column family you configure, or the default one: + +| Key prefix | Value | +| ---------- | ----------------------------- | +| `0x90` | header (`BlockNode`) by hash | +| `0x91` | best header | +| `0x92` | data version | + +You can keep your own data in the same database, as Haskoin Store does, as long +as your keys do not start with these bytes. + +## Usage guide + +### Picking a peer and requesting data + +```haskell +ps <- getPeers node.peerMgr -- online peers, fastest first +case ps of + op : _ -> do + let p = op.mailbox + mblocks <- getBlocks btc 30 p [blockHash] -- Maybe [Block] + mtxs <- getTxs btc 30 p [txHash] -- Maybe [Tx] + sendMessage MMempool p + [] -> return () +``` + +`getBlocks`, `getTxs` and `getData` return `Nothing` if the peer does not send +everything, in order, before the timeout in seconds. `pingPeer` measures a round +trip. + +### Querying headers + +```haskell +best <- chainGetBest node.chain +mnode <- chainGetBlock node.chain someHash +isMain <- chainBlockMain node.chain someHash +fork <- chainGetSplitBlock node.chain nodeA nodeB +parents <- chainGetParents node.chain height top +synced <- chainIsSynced node.chain +``` + +`runChainT` runs the header functions of haskoin-core, such as `getAncestor`, +against the database of the chain. + +### Static peers + +```haskell +cfg {peers = ["node1.example.com", "10.0.0.5:8333", "[2001:db8::1]:8333"], discover = False} +``` + +A peer without a port uses the default port of the network. + +### 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. + +### Logging + +`withLogger level` logs to standard error, one line per message, such as +`[Info#Chain] Best block header at height 870000`. Build a `Logger` with your +own `push` function to log elsewhere. + +## Configuration + +| Field | Meaning | +| ------------- | ------------------------------------------------------------------------- | +| `maxPeers` | Maximum number of peers to connect to | +| `db` | RocksDB handle for the headers | +| `cf` | Column family for the headers, or `Nothing` for the default one | +| `peers` | Static peers, as `host`, `host:port` or `[ipv6]:port` | +| `discover` | Use DNS seeds and addresses relayed by peers | +| `address` | This node's address, sent in version messages | +| `net` | Network constants from haskoin-core (`btc`, `bch`, `btcTest`, ...) | +| `pub` | Publisher that receives every `NodeEvent` | +| `timeout` | Seconds of silence, or without a pong, before a peer is dropped | +| `maxPeerLife` | Seconds after which a peer is dropped, so that connections rotate | +| `connect` | How to open a connection; usually `withConnection` | +| `logger` | Where to log; see `withLogger` | + +## Module overview + +`Haskoin.Node` is the only exposed module. It re-exports: + +| Part | Contents | +| -------------- | --------------------------------------------------------------------------- | +| Node | `NodeConfig`, `NodeEvent`, `Node`, `withNode`, `withConnection` | +| Peers | `Peer`, `PeerEvent`, `sendMessage`, `getBlocks`, `getTxs`, `getData`, `pingPeer`, `killPeer` | +| Peer manager | `PeerMgr`, `OnlinePeer`, `getPeers`, `getOnlinePeer`, `toSockAddr`, `isRoutable` | +| Chain | `Chain`, `ChainEvent`, `chainGetBest`, `chainGetBlock`, `chainGetAncestor`, `chainGetParents`, `chainGetSplitBlock`, `chainBlockMain`, `chainIsSynced`, `runChainT` | +| Logging | `Logger`, `LogLevel`, `withLogger`, `withSource`, `logDebug` ... `logError` | + +The lower-level functions that feed messages to the peer manager and the chain +are exported too, for programs that wire the components themselves. + +## 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. +- List messages are refused as soon as their count is over the limit, such as + 2000 headers, 1000 addresses or 50000 inventory entries. +- A peer that sends anything invalid is disconnected. +- 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. +- 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. + +## Development + +```sh +git clone https://github.com/jprupp/haskoin-node.git +cd haskoin-node + +stack build # build the library +stack test # run the tests +stack haddock --no-haddock-deps # build the API documentation +``` + +On NixOS, or with `stack --nix`, the `nix` section of `stack.yaml` provides +RocksDB and libsecp256k1. + +`package.yaml` is the source of the package description. Change it rather than +`haskoin-node.cabal`, which [hpack](https://github.com/sol/hpack) generates. + +The tests are in `test/` and use [hspec](https://hspec.github.io/). They run +against mock peers on the Bitcoin Cash regression test network, so they need no +Internet access. + +### Contributing + +Pull requests are welcome. + +- Format the code with [Ormolu](https://github.com/tweag/ormolu). +- Add tests for the behaviour you change. +- 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/). + +## Related projects + +- [haskoin-core](https://github.com/jprupp/haskoin-core) has the Bitcoin data + types and protocol that this library speaks. +- [haskoin-store](https://github.com/jprupp/haskoin-store) indexes blocks and + transactions on top of this node and serves them over a REST API. +- [nqe](https://github.com/jprupp/nqe) provides the processes, supervisors and + publishers. +- [rocksdb-query](https://github.com/jprupp/rocksdb-query) stores the headers. + +## License + +Haskoin Node is released under the +[MIT License](https://github.com/jprupp/haskoin-node/blob/master/LICENSE). diff --git a/haskoin-node.cabal b/haskoin-node.cabal --- a/haskoin-node.cabal +++ b/haskoin-node.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: haskoin-node -version: 2.3.0 +version: 2.3.1 synopsis: P2P library for Bitcoin and Bitcoin Cash description: Please see the README on GitHub at category: Bitcoin, Finance, Network diff --git a/src/Haskoin/Node.hs b/src/Haskoin/Node.hs --- a/src/Haskoin/Node.hs +++ b/src/Haskoin/Node.hs @@ -8,16 +8,120 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NoFieldSelectors #-} +-- | +-- Module : Haskoin.Node +-- Copyright : (c) Haskoin Developers +-- License : MIT +-- Maintainer : jprupp@protonmail.ch +-- Stability : experimental +-- Portability : POSIX +-- +-- A peer-to-peer node for Bitcoin (BTC) and Bitcoin Cash (BCH). +-- +-- The node connects to other peers on the network, keeps a number of them +-- online, and synchronises the block chain headers, which it stores in a +-- RocksDB database. It does not download or validate full blocks or +-- transactions by itself: it publishes events and lets the application request +-- whatever data it needs from the connected peers. +-- +-- A node is made of two main components, which run in their own threads: +-- +-- * The peer manager ("Haskoin.Node.PeerMgr") discovers and connects to peers, +-- performs the version handshake, pings peers to measure latency, and +-- disconnects peers that misbehave, are too slow or have been connected for +-- too long. +-- +-- * The chain ("Haskoin.Node.Chain") downloads block headers from peers, +-- connects them to the best chain, and stores them in the database. +-- +-- 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. +-- +-- = Purpose +-- +-- Talking to the Bitcoin network well is a job of its own, independent of what +-- a program does with the data. Peers have to be found, kept, measured and +-- dropped; messages have to be parsed defensively, because anyone can connect; +-- and the header chain, the backbone that tells which blocks are real, has to +-- be followed through reorganisations. This library does that job and nothing +-- else, so that wallets, indexers and monitors can be built on it without each +-- reimplementing it. +-- +-- = Design +-- +-- * __Headers only.__ The node syncs block headers, which are small and enough +-- to know the best chain, and leaves blocks and transactions to the +-- application. Applications differ wildly in what they need: an indexer wants +-- every block, a wallet a few transactions, a monitor nothing but +-- announcements. Fetching on request serves all of them. +-- +-- * __Events, not callbacks.__ Everything the node learns is published. The +-- node does not know who listens or how many listeners there are, and a slow +-- listener cannot reach into the node's own state. +-- +-- * __Processes with one job each.__ The peer manager, the chain and every +-- peer connection are separate NQE processes. Each owns its state and is fed +-- by messages, which keeps the concurrency easy to reason about and lets a +-- failing peer die without disturbing the rest. +-- +-- * __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. +-- +-- = Example +-- +-- @ +-- main :: IO () +-- main = +-- 'withLogger' 'LevelInfo' $ \\logger -> +-- withDB "\/tmp\/node" def{createIfMissing = True} $ \\db -> +-- 'withPublisher' $ \\pub -> +-- 'withSubscription' pub $ \\events -> do +-- let cfg = +-- 'NodeConfig' +-- { maxPeers = 8, +-- db = db, +-- cf = Nothing, +-- peers = [], +-- discover = True, +-- address = NetworkAddress 0 (sockToHostAddress (SockAddrInet 0 0)), +-- net = btc, +-- pub = pub, +-- timeout = 120, +-- maxPeerLife = 48 * 3600, +-- connect = 'withConnection', +-- logger = logger +-- } +-- 'withNode' cfg $ \\node -> forever $ +-- 'receive' events >>= \\case +-- 'ChainEvent' ('ChainBestBlock' bn) -> print bn.height +-- _ -> return () +-- @ +-- +-- = Requesting data +-- +-- Use 'getPeers' to list the peers that are online, then 'getBlocks', +-- 'getTxs' or 'getData' to request data from one of them. Use +-- 'chainGetBlock', 'chainGetBest' and related functions to query the headers +-- that the node has stored. module Haskoin.Node - ( module Haskoin.Node.Peer, - module Haskoin.Node.PeerMgr, - module Haskoin.Node.Chain, - module Haskoin.Node.Logger, + ( -- * Node NodeConfig (..), NodeEvent (..), Node (..), withNode, withConnection, + -- * Peers + module Haskoin.Node.Peer, + -- * Peer manager + module Haskoin.Node.PeerMgr, + -- * Chain + module Haskoin.Node.Chain, + -- * Logging + module Haskoin.Node.Logger, ) where @@ -38,7 +142,10 @@ import Text.Read (readMaybe) import UnliftIO --- | General node configuration. +-- | General node configuration. Passed to 'withNode'. +-- +-- Connecting is a parameter ('connect') rather than hard-wired so that tests can +-- plug in simulated peers, and deployments can route through a proxy. data NodeConfig = NodeConfig { -- | maximum number of connected peers allowed maxPeers :: !Int, @@ -56,25 +163,40 @@ net :: !Network, -- | node events are sent to this publisher pub :: !(Publisher NodeEvent), - -- | timeout in seconds + -- | seconds without a response before a peer is considered unresponsive + -- and disconnected; also used as timeout for handshakes and for syncing + -- headers timeout :: !NominalDiffTime, - -- | peer disconnect after seconds + -- | disconnect a peer after it has been connected for this many seconds, + -- so that connections rotate over time maxPeerLife :: !NominalDiffTime, + -- | how to open a connection to a peer address; normally + -- 'withConnection', but can be replaced to use a proxy or for testing connect :: !(SockAddr -> WithConnection), -- | log messages here logger :: !Logger } +-- | A running node, as given by 'withNode'. Use its fields to query and +-- control the peer manager and the chain. data Node = Node - { peerMgr :: !PeerMgr, + { -- | the peer manager + peerMgr :: !PeerMgr, + -- | the block header chain chain :: !Chain } +-- | Events published by the node to the 'Publisher' in 'NodeConfig'. data NodeEvent - = ChainEvent !ChainEvent - | PeerEvent !PeerEvent + = -- | something happened to the header chain, such as a new best block + ChainEvent !ChainEvent + | -- | a peer connected, disconnected or sent a message + PeerEvent !PeerEvent deriving (Eq) +-- | 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. withConnection :: SockAddr -> WithConnection withConnection na f = fromSockAddr na >>= \case @@ -83,6 +205,8 @@ runTCPClient cset $ \ad -> f (Conduits (appSource ad) (appSink ad)) +-- | Turn a socket address into client settings for a TCP connection, or +-- 'Nothing' if it cannot be converted. fromSockAddr :: (MonadUnliftIO m) => SockAddr -> m (Maybe ClientSettings) fromSockAddr sa = go `catch` e where @@ -96,6 +220,9 @@ e :: (Monad m) => SomeException -> m (Maybe a) e _ = return Nothing +-- | Forward events from the chain to the node publisher, telling the peer +-- manager about every new best block height so that it can tell peers apart +-- that are behind. chainEvents :: (MonadIO m) => PeerMgr -> Inbox ChainEvent -> Publisher NodeEvent -> m () chainEvents mgr input output = loopForever $ do @@ -145,6 +272,10 @@ _ -> return () -- | Launch node process in the foreground. +-- +-- Start the chain and the peer manager in background threads, pass a 'Node' +-- handle to the given action, and stop everything when the action returns. If +-- any component fails, the exception is re-thrown in the calling thread. withNode :: (MonadUnliftIO m) => NodeConfig -> (Node -> m a) -> m a withNode NodeConfig {..} action = flip runContT return $ do diff --git a/src/Haskoin/Node/Chain.hs b/src/Haskoin/Node/Chain.hs --- a/src/Haskoin/Node/Chain.hs +++ b/src/Haskoin/Node/Chain.hs @@ -15,6 +15,57 @@ {-# LANGUAGE NoFieldSelectors #-} {-# OPTIONS_GHC -fno-warn-orphans #-} +-- | +-- Module : Haskoin.Node.Chain +-- Copyright : (c) Haskoin Developers +-- License : MIT +-- Maintainer : jprupp@protonmail.ch +-- Stability : experimental +-- Portability : POSIX +-- +-- The block header chain. +-- +-- The chain process downloads block headers from connected peers, one peer at a +-- time, connects them to the headers it already has, and stores them in RocksDB. +-- It follows the chain with the most work, and publishes a 'ChainBestBlock' +-- event whenever the best block changes. Once the best block is recent (less +-- than two hours old), has at least the minimum chain work of the network, and +-- no peer is left to sync from, it publishes a single 'ChainSynced' event. +-- +-- After a peer has delivered all its headers, it is asked to announce new +-- blocks with headers messages, which are fed back to the chain process by +-- "Haskoin.Node". +-- +-- = Why it works this way +-- +-- * __One peer at a time.__ Headers form a single chain, so asking several +-- peers for the same range at once would only download it several times. +-- The chain syncs from one peer and moves to the next when it is done or +-- times out, which also means every connected peer eventually gets a chance +-- to show a better chain. +-- +-- * __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. +-- +-- * __"Synced" has to be earned.__ Recent headers alone do not prove much: a +-- peer can feed a cheap chain with fresh timestamps. The chain only counts as +-- synced once its work reaches the network's minimum chain work, the same +-- guard Bitcoin Core uses before leaving initial block download. Applications +-- use 'ChainSynced' to start work that only makes sense at the tip, so a false +-- signal would be costly. +-- +-- * __Headers are stored, not kept in memory.__ Storing them in RocksDB lets a +-- restart resume where it stopped instead of downloading the whole chain +-- again. +-- +-- = Database +-- +-- Headers are stored as 'BlockNode' values in the configured column family, or +-- the default one, under keys starting with byte @0x90@. The best block is +-- stored under key @0x91@ and a data version under key @0x92@. If the data +-- version does not match, keys @0x90@ and @0x91@ are deleted when the chain +-- starts. Applications that share the database must not use these prefixes. module Haskoin.Node.Chain ( ChainConfig (..), ChainEvent (..), @@ -70,31 +121,43 @@ net :: !Network, -- | send header chain events here pub :: !(Publisher ChainEvent), - -- | timeout in seconds + -- | seconds to wait for headers from the syncing peer before it is + -- disconnected timeout :: !NominalDiffTime, -- | log messages here logger :: !Logger } +-- | Messages handled by the chain process. data ChainMessage - = ChainHeaders !Peer ![BlockHeader] - | ChainPeerConnected !Peer - | ChainPeerDisconnected !Peer - | ChainPing - | ChainSyncMsg !(Listen ()) + = -- | a peer sent headers + ChainHeaders !Peer ![BlockHeader] + | -- | a peer completed the handshake + ChainPeerConnected !Peer + | -- | a peer disconnected + ChainPeerDisconnected !Peer + | -- | periodic tick to check the syncing peer for timeouts + ChainPing + | -- | reply once every previous message has been handled + ChainSyncMsg !(Listen ()) -- | Events originating from chain syncing process. data ChainEvent = -- | chain has new best block ChainBestBlock !BlockNode - | -- | chain is in sync with the network + | -- | chain is in sync with the network; published only once, with the best + -- block at that time ChainSynced !BlockNode deriving (Eq, Show) --- | State and configuration. +-- | Handle to a running chain process. Obtain one with 'withChain', or from +-- the 'Haskoin.Node.Node' returned by 'Haskoin.Node.withNode'. data Chain = Chain - { config :: !ChainConfig, + { -- | configuration + config :: !ChainConfig, + -- | mailbox of the chain process mailbox :: !(Mailbox ChainMessage), + -- | syncing state state :: !(TVar ChainState) } @@ -115,9 +178,13 @@ return ChainDataVersionKey put ChainDataVersionKey = putWord8 0x92 +-- | State of the sync against one peer. data ChainSync = ChainSync - { peer :: !Peer, + { -- | peer being synced against + peer :: !Peer, + -- | when it last sent headers, or when syncing started timestamp :: !UTCTime, + -- | last header it sent, from which to continue syncing best :: !(Maybe BlockNode) } @@ -155,11 +222,17 @@ return BestBlockKey put BestBlockKey = putWord8 0x91 +-- | Monad transformer with access to a 'Chain'. It has a 'BlockHeaders' +-- instance, so the header functions of haskoin-core, such as 'getAncestor' and +-- 'splitPoint', can run in it against the database of the chain. type ChainT m = ReaderT Chain m +-- | Run a 'ChainT' action against a chain. runChainT :: ChainT m a -> Chain -> m a runChainT = runReaderT +-- | Read and write headers in the database of a chain configuration. Orphan +-- instance. instance (MonadIO m) => BlockHeaders (ReaderT ChainConfig m) where addBlockHeader bn = ReaderT $ \ChainConfig {db, cf} -> liftIO $ do case cf of @@ -185,6 +258,7 @@ Nothing -> insertOp (BlockHeaderKey (h bn)) bn Just cf' -> insertOpCF cf' (BlockHeaderKey (h bn)) bn +-- | Read and write headers in the database of a chain. Orphan instance. instance (MonadIO m) => BlockHeaders (ChainT m) where addBlockHeader bn = withReaderT (.config) (addBlockHeader bn) getBlockHeader bh = withReaderT (.config) (getBlockHeader bh) @@ -192,6 +266,13 @@ setBestBlockHeader bn = withReaderT (.config) (setBestBlockHeader bn) addBlockHeaders bns = withReaderT (.config) (addBlockHeaders bns) +-- | Start the chain process and pass its handle to the given action. The process +-- is stopped when the action returns, and its exceptions are re-thrown in the +-- calling thread. +-- +-- The database is initialised first: purged if its data version is old, and +-- seeded with the genesis block of the network if it has no best block. The +-- current best block is published as a 'ChainBestBlock' event on start. withChain :: (MonadUnliftIO m) => ChainConfig -> (Chain -> m a) -> m a withChain cfg action = do @@ -218,6 +299,7 @@ msg <- receive inbox chainConfigMessage ch msg +-- | Log and publish a chain event. chainEvent :: (MonadIO m) => ChainConfig -> ChainEvent -> m () chainEvent cfg e = do case e of @@ -231,6 +313,10 @@ ("Headers in sync at height " <> cs (show b.height)) publish e cfg.pub +-- | Import headers sent by a peer. Disconnect the peer if they do not connect. +-- Publish a new best block if it changed. If the peer has no more headers, move +-- on to the next peer and check whether the chain is now in sync; otherwise ask +-- it for more. processHeaders :: (MonadIO m) => Chain -> Peer -> [BlockHeader] -> m () processHeaders ch p hs = do let len = length hs @@ -259,6 +345,7 @@ syncNotif ch else syncPeer ch p +-- | Start syncing against the next peer in the queue, unless a peer is already being synced. syncNewPeer :: (MonadIO m) => Chain -> m () syncNewPeer ch = getSyncingPeer ch.state >>= \case @@ -270,6 +357,7 @@ logDebug ch.config.logger ("Syncing against peer " <> p.label) syncPeer ch p +-- | Publish a 'ChainSynced' event if the chain just became synced. syncNotif :: (MonadIO m) => Chain -> m () syncNotif ch = notifySynced ch >>= \case @@ -278,6 +366,8 @@ runReaderT getBestBlockHeader ch.config >>= chainEvent ch.config . ChainSynced +-- | Ask a peer for headers, continuing from the last header it sent, or from the +-- best block. Does nothing if another peer is being synced. syncPeer :: (MonadIO m) => Chain -> Peer -> m () syncPeer ch p = do t <- liftIO getCurrentTime @@ -306,6 +396,7 @@ Just h -> return h Just <$> syncHeaders ch t h p +-- | Handle a message sent to the chain process. chainConfigMessage :: (MonadIO m) => Chain -> ChainMessage -> m () chainConfigMessage ch (ChainHeaders p hs) = processHeaders ch p hs @@ -333,6 +424,8 @@ | otherwise -> return () Nothing -> syncNewPeer ch +-- | Run a loop in the background that sends a 'ChainPing' to the chain process +-- every 2 to 20 seconds. withSyncLoop :: (MonadUnliftIO m) => Mailbox ChainMessage -> m a -> m a withSyncLoop mbox mf = withAsync go $ \a -> @@ -502,6 +595,8 @@ ChainState {syncing = Just ChainSync {peer}} -> return (Just peer) _ -> return Nothing +-- | Reserve a peer with 'setBusy' and make it the syncing peer. Returns 'False' +-- if the peer is busy with something else. setSyncingPeer :: (MonadIO m) => Chain -> Peer -> m Bool setSyncingPeer ch p = setBusy p >>= \case @@ -565,7 +660,8 @@ chainSyncingPeer :: (MonadIO m) => TVar ChainState -> m (Maybe ChainSync) chainSyncingPeer st = (.syncing) <$> readTVarIO st --- | Get a block header from the block chain. +-- | Get a block header from the block chain. Returns headers on side chains +-- too; use 'chainBlockMain' to check whether a block is in the main chain. chainGetBlock :: (MonadIO m) => Chain -> BlockHash -> m (Maybe BlockNode) chainGetBlock ch bh = runReaderT (getBlockHeader bh) ch.config @@ -573,12 +669,15 @@ chainGetBest :: (MonadIO m) => Chain -> m BlockNode chainGetBest ch = runReaderT getBestBlockHeader ch.config --- | Get ancestor of 'BlockNode' at 'BlockHeight' from chain process. +-- | Get ancestor of 'BlockNode' at 'BlockHeight' from chain process. Returns +-- 'Nothing' if the height is above that of the node. chainGetAncestor :: (MonadIO m) => Chain -> BlockHeight -> BlockNode -> m (Maybe BlockNode) chainGetAncestor ch h bn = runReaderT (getAncestor h bn) ch.config -- | Get parents of 'BlockNode' starting at 'BlockHeight' from chain process. +-- The result is in ascending order, from the block at the given height up to +-- the parent of the given node, which is not included. chainGetParents :: (MonadIO m) => Chain -> BlockHeight -> BlockNode -> m [BlockNode] chainGetParents ch height top = @@ -592,12 +691,14 @@ Nothing -> return acc Just p -> go (p : acc) p --- | Get last common block from chain process. +-- | Get last common block from chain process: the most recent block that is an +-- ancestor of both nodes. chainGetSplitBlock :: (MonadIO m) => Chain -> BlockNode -> BlockNode -> m BlockNode chainGetSplitBlock ch l r = runReaderT (splitPoint l r) ch.config --- | Notify chain that a new peer is connected. +-- | Notify chain that a new peer is connected. It is added to the queue of +-- peers to sync against. chainPeerConnected :: (MonadIO m) => Chain -> Peer -> m () chainPeerConnected ch p = ChainPeerConnected p `send` ch.mailbox @@ -617,12 +718,14 @@ bm@(Just bn) -> (== bm) <$> chainGetAncestor ch bn.height bb --- | Is chain in sync with network? +-- | Is chain in sync with network? Once 'True', it stays 'True' even if the +-- chain falls behind later. chainIsSynced :: (MonadIO m) => Chain -> m Bool chainIsSynced ch = (.beenInSync) <$> readTVarIO (ch.state) --- | Peer sends a bunch of headers to the chain process. +-- | Peer sends a bunch of headers to the chain process. "Haskoin.Node" calls +-- this for every headers message received from an online peer. chainHeaders :: (MonadIO m) => Chain -> Peer -> [BlockHeader] -> m () chainHeaders ch p hs = ChainHeaders p hs `send` ch.mailbox diff --git a/src/Haskoin/Node/Logger.hs b/src/Haskoin/Node/Logger.hs --- a/src/Haskoin/Node/Logger.hs +++ b/src/Haskoin/Node/Logger.hs @@ -6,6 +6,11 @@ -- | Logging to standard error. A 'Logger' is a plain value carried in -- configuration records, so code that logs only needs 'MonadIO'. +-- +-- The node used to log through a logging monad transformer. That forced every +-- function into that monad, and made polymorphic loops leak memory when GHC did +-- not specialise them (see "Haskoin.Node.Loop"). A plain value avoids both, and +-- programs that log elsewhere can supply their own @push@ function. module Haskoin.Node.Logger ( Logger (..), LogLevel (..), @@ -31,9 +36,21 @@ ) import UnliftIO (MonadIO, bracket, liftIO) -data LogLevel = LevelDebug | LevelInfo | LevelWarn | LevelError +-- | Severity of a log message, from least to most severe. +data LogLevel + = -- | detailed tracing, useful when debugging + LevelDebug + | -- | normal operation, such as peers connecting and blocks arriving + LevelInfo + | -- | unexpected events that the node recovers from + LevelWarn + | -- | failures + LevelError deriving (Eq, Ord, Show) +-- | Where and how to log. Every component of the node takes one in its +-- configuration. Build one with 'withLogger', or directly with any @push@ +-- function to send log lines elsewhere. data Logger = Logger { -- | messages below this level are dropped level :: !LogLevel, @@ -50,11 +67,13 @@ bracket (newFastLogger1 (LogStderr defaultBufSize)) snd $ \(push, _) -> go Logger {level, source = "", push} --- | Same output with a different tag. +-- | Same output with a different tag. The node uses this to tag the messages of +-- each component, such as @Chain@ and @PeerMgr@. withSource :: Text -> Logger -> Logger withSource source logger = logger {source} --- | Lines look like monad-logger's: @[Info#Chain] message@. +-- | Log a message at a level, if the level is at least that of the 'Logger'. +-- Lines look like monad-logger's: @[Info#Chain] message@. logAt :: (MonadIO m) => LogLevel -> Logger -> Text -> m () logAt l logger msg = when (l >= logger.level) . liftIO . logger.push $ @@ -64,6 +83,7 @@ | T.null logger.source = "" | otherwise = "#" <> toLogStr logger.source +-- | Log at 'LevelDebug', 'LevelInfo', 'LevelWarn' or 'LevelError'. logDebug, logInfo, logWarn, logError :: (MonadIO m) => Logger -> Text -> m () logDebug = logAt LevelDebug logInfo = logAt LevelInfo diff --git a/src/Haskoin/Node/Loop.hs b/src/Haskoin/Node/Loop.hs --- a/src/Haskoin/Node/Loop.hs +++ b/src/Haskoin/Node/Loop.hs @@ -12,6 +12,8 @@ -- stacks, so it never accumulates. module Haskoin.Node.Loop (loopForever) where +-- | Run an action over and over, forever, discarding its results. Only +-- exceptions stop the loop. loopForever :: (Monad m) => m a -> m b loopForever action = go where diff --git a/src/Haskoin/Node/Peer.hs b/src/Haskoin/Node/Peer.hs --- a/src/Haskoin/Node/Peer.hs +++ b/src/Haskoin/Node/Peer.hs @@ -11,6 +11,37 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE NoFieldSelectors #-} +-- | +-- Module : Haskoin.Node.Peer +-- Copyright : (c) Haskoin Developers +-- License : MIT +-- Maintainer : jprupp@protonmail.ch +-- Stability : experimental +-- Portability : POSIX +-- +-- A single connection to a peer on the Bitcoin network. +-- +-- Each peer runs as its own process. It reads messages from the network, +-- parses them, and publishes them as 'PeerEvent's. It also accepts messages to +-- send to the peer through its mailbox. Peers are normally started and managed +-- by "Haskoin.Node.PeerMgr"; applications mostly use 'sendMessage', +-- 'getBlocks', 'getTxs' and 'getData' on peers obtained from +-- 'Haskoin.Node.PeerMgr.getPeers'. +-- +-- = Defensive by design +-- +-- A peer is anyone on the Internet. The code here assumes the worst of it: +-- +-- * The 24-byte header of each message is read and checked first: network +-- magic, and payload size against the limit for that command. Only then is +-- the payload read, so a peer cannot make the node buffer a huge message it +-- would refuse anyway. +-- +-- * Anything that does not parse closes the connection. There is no attempt to +-- recover, because a peer that sends garbage once is not worth the risk. +-- +-- * 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 ( PeerConfig (..), PeerEvent (..), @@ -54,32 +85,55 @@ import System.Random import UnliftIO +-- | The two directions of a network connection, as conduits. +-- +-- Connections are abstract conduits rather than sockets, so that the same peer +-- code runs over TCP, through a proxy, or against an in-memory mock in tests. data Conduits = Conduits - { inboundConduit :: ConduitT () ByteString IO (), + { -- | bytes received from the peer + inboundConduit :: ConduitT () ByteString IO (), + -- | bytes to send to the peer outboundConduit :: ConduitT ByteString Void IO () } +-- | A function that opens a connection, passes its 'Conduits' to the given +-- action, and closes the connection when the action returns. type WithConnection = (Conduits -> IO ()) -> IO () +-- | Configuration of a peer process. data PeerConfig = PeerConfig - { pub :: !(Publisher PeerEvent), + { -- | peer events are published here + pub :: !(Publisher PeerEvent), + -- | network constants net :: !Network, + -- | name of the peer in logs, usually its address label :: !Text, + -- | how to open the connection to the peer connect :: !WithConnection, + -- | log messages here logger :: !Logger } +-- | Events published about peers. data PeerEvent - = PeerConnected !Peer - | PeerDisconnected !Peer - | PeerMessage !Peer !Message + = -- | the peer completed the version handshake and is online + PeerConnected !Peer + | -- | the peer disconnected + PeerDisconnected !Peer + | -- | the peer sent a message + PeerMessage !Peer !Message deriving (Eq) --- | Mailbox for a peer. +-- | Mailbox for a peer. Peers are compared by their mailbox, and shown by their +-- label. data Peer = Peer - { mailbox :: !(Mailbox PeerMessage), + { -- | send 'PeerMessage's to the peer process here + mailbox :: !(Mailbox PeerMessage), + -- | events from this peer are published here pub :: !(Publisher PeerEvent), + -- | name of the peer in logs, usually its address label :: !Text, + -- | whether the peer is reserved for a task; see 'setBusy' busy :: !(TVar Bool), -- | messages from this peer that the node has not finished handling pending :: !(TVar Int) @@ -93,9 +147,13 @@ -- | Incoming messages that a peer accepts. data PeerMessage - = KillPeer - | SendMessage !Message + = -- | disconnect from the peer + KillPeer + | -- | send a network message to the peer + SendMessage !Message +-- | Build a 'Peer' handle from its configuration, its busy flag, its counter of +-- pending messages, and the mailbox of its process. wrapPeer :: PeerConfig -> TVar Bool -> @@ -125,6 +183,11 @@ -- | Run peer process in current thread. The 'Peer' must be the one that -- 'wrapPeer' built with the mailbox of this inbox. +-- +-- Opens the connection, then reads and publishes messages from the peer while +-- sending the messages that arrive in the inbox. Returns when 'killPeer' is +-- called or the connection is closed, and throws if the peer sends invalid +-- data. peer :: (MonadUnliftIO m) => PeerConfig -> @@ -231,17 +294,25 @@ outPeerConduit :: (Monad m) => Network -> ConduitT Message ByteString m () outPeerConduit net = awaitForever $ yield . runPut . putMessage net --- | Kill a peer with the provided exception. +-- | Ask a peer to disconnect. The peer process stops after sending any messages +-- queued before this one. killPeer :: (MonadIO m) => Peer -> m () killPeer p = KillPeer `send` p.mailbox --- | Send a network message to peer. +-- | Send a network message to peer. Returns as soon as the message is queued. sendMessage :: (MonadIO m) => Message -> Peer -> m () sendMessage msg p = SendMessage msg `send` p.mailbox +-- | Check whether a peer is reserved for a task. getBusy :: (MonadIO m) => Peer -> m Bool getBusy p = readTVarIO p.busy +-- | Try to reserve a peer for a task, such as syncing headers. Returns 'True' if +-- the peer was free and is now reserved, or 'False' if it was already busy. +-- +-- Reservation exists because some conversations with a peer span many +-- messages, like downloading a long run of headers. Two tasks using the same peer +-- for such a conversation at once would confuse each other's replies. setBusy :: (MonadIO m) => Peer -> m Bool setBusy p = atomically $ do @@ -249,12 +320,16 @@ unless b $ writeTVar p.busy True return $ not b +-- | Release a peer reserved with 'setBusy'. setFree :: (MonadIO m) => Peer -> m () setFree p = atomically $ writeTVar p.busy False -- | Request full blocks from peer. Will return 'Nothing' if the list of blocks -- returned by the peer is incomplete, comes out of order, or a timeout is -- reached. +-- +-- The 'Int' argument is the timeout in seconds. On networks with SegWit, +-- blocks are requested with their witness data. getBlocks :: (MonadUnliftIO m) => Network -> @@ -275,6 +350,9 @@ -- | Request transactions from peer. Will return 'Nothing' if the list of -- transactions returned by the peer is incomplete, comes out of order, or a -- timeout is reached. +-- +-- The 'Int' argument is the timeout in seconds. Peers normally only serve +-- transactions that are in their mempool. getTxs :: (MonadUnliftIO m) => Network -> @@ -295,6 +373,11 @@ -- | Request transactions and/or blocks from peer. Return 'Nothing' if any -- single inventory fails to be retrieved, if they come out of order, or if -- timeout is reached. +-- +-- The first argument is the timeout in seconds. A ping is sent right after the +-- request; since peers answer in order, receiving the matching pong before all +-- items means that the peer will not send the rest. Transactions are returned +-- as 'Left' and blocks as 'Right', in the order they were requested. getData :: (MonadUnliftIO m) => Int -> Peer -> GetData -> m (Maybe [Either Tx Block]) getData seconds p gd@(GetData ivs) = @@ -336,7 +419,7 @@ is_block _ = False -- | Ping a peer and await response. Return 'False' if response not received --- before timeout. +-- before timeout. The first argument is the timeout in seconds. pingPeer :: (MonadUnliftIO m) => Int -> Peer -> m Bool pingPeer time p = fmap isJust . withSubscription p.pub $ \sub -> do @@ -347,6 +430,8 @@ | p == p' && r == r' -> Just () _ -> Nothing +-- | Receive the next message from the given peer, discarding events about other +-- peers. filterReceive :: (MonadIO m) => Peer -> Inbox PeerEvent -> m Message filterReceive p inb = receive inb >>= \case diff --git a/src/Haskoin/Node/PeerMgr.hs b/src/Haskoin/Node/PeerMgr.hs --- a/src/Haskoin/Node/PeerMgr.hs +++ b/src/Haskoin/Node/PeerMgr.hs @@ -11,6 +11,53 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE NoFieldSelectors #-} +-- | +-- Module : Haskoin.Node.PeerMgr +-- Copyright : (c) Haskoin Developers +-- License : MIT +-- Maintainer : jprupp@protonmail.ch +-- Stability : experimental +-- Portability : POSIX +-- +-- The peer manager keeps the node connected to the network. +-- +-- It maintains a pool of known peer addresses, filled from the static peers in +-- the configuration, from the DNS seeds of the network when discovery is on, and +-- from addresses relayed by connected peers. A background loop connects to new +-- peers while there are fewer than 'maxPeers' of them. +-- +-- For each connection, the peer manager sends a version message, waits for the +-- peer's version and acknowledgement, and then announces the peer as connected +-- with a 'PeerConnected' event. Peers are pinged periodically to measure their +-- latency, and the list returned by 'getPeers' is sorted by median ping time, so +-- that the fastest peers come first. A peer is disconnected if it stops +-- responding, does not answer a ping in time, or has been connected for longer +-- than 'maxPeerLife'. A 'PeerDisconnected' event is published when an online +-- peer goes away. +-- +-- Most of the @peerMgr*@ functions are used by "Haskoin.Node" to feed messages +-- received from peers to the peer manager; applications rarely need to call +-- them directly. +-- +-- = Why it works this way +-- +-- * __Peers are ranked by measured latency.__ The fastest peers deliver +-- blocks and transactions soonest, so applications that pick the first peer +-- from 'getPeers' get the best service without measuring anything themselves. +-- +-- * __Connections rotate.__ Peers are dropped after 'maxPeerLife' even when +-- they behave. A node that keeps the same few peers forever is easier to +-- isolate from the honest network, and stuck with them if they degrade. +-- Rotation keeps the peer set fresh. +-- +-- * __Silence is failure.__ A peer that sends nothing, or ignores a ping, for +-- longer than 'timeout' is dropped. Waiting for a peer that has gone away +-- would stall whatever was waiting on it. +-- +-- * __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. module Haskoin.Node.PeerMgr ( PeerMgrConfig (..), PeerEvent (..), @@ -58,52 +105,102 @@ import UnliftIO import UnliftIO.Concurrent +-- | Configuration of the peer manager. "Haskoin.Node" builds it from the +-- 'Haskoin.Node.NodeConfig'. data PeerMgrConfig = PeerMgrConfig - { maxPeers :: !Int, + { -- | maximum number of peers to connect to + maxPeers :: !Int, + -- | static peers to connect to, as @host@ or @host:port@; IPv6 addresses + -- go in square brackets, as in @[::1]:8333@ peers :: ![String], + -- | connect to the network seeds and to addresses relayed by peers discover :: !Bool, + -- | address of this node, sent in version messages address :: !NetworkAddress, + -- | network constants net :: !Network, + -- | peer events are published here pub :: !(Publisher PeerEvent), + -- | seconds without a message from a peer, or without an answer to a + -- ping, before it is disconnected timeout :: !NominalDiffTime, + -- | seconds after which a peer is disconnected regardless maxPeerLife :: !NominalDiffTime, + -- | how to open a connection to a peer address connect :: !(SockAddr -> WithConnection), + -- | log messages here logger :: !Logger } +-- | Handle to a running peer manager. Obtain one with 'withPeerMgr', or from +-- the 'Haskoin.Node.Node' returned by 'Haskoin.Node.withNode'. data PeerMgr = PeerMgr - { config :: !PeerMgrConfig, + { -- | configuration + config :: !PeerMgrConfig, + -- | supervisor that runs the peer processes supervisor :: !Supervisor, + -- | mailbox of the peer manager process mailbox :: !(Mailbox PeerMgrMessage), + -- | height of the best block, sent to peers in version messages best :: !(TVar BlockHeight), + -- | known addresses not yet connected to, at most 'maxKnownAddresses' addresses :: !(TVar (Set SockAddr)), + -- | peers being connected to or online, fastest first peers :: !(TVar [OnlinePeer]) } +-- | Messages handled by the peer manager process. data PeerMgrMessage - = Connect !SockAddr - | CheckPeer !Peer - | PeerDied !Child - | ManagerBest !BlockHeight - | PeerVerAck !Peer - | PeerVersion !Peer !Version - | PeerPing !Peer !Word64 - | PeerPong !Peer !Word64 - | PeerAddrs !Peer ![NetworkAddress] - | Sync !(Listen ()) + = -- | connect to a peer address + Connect !SockAddr + | -- | check whether a peer timed out or must be pinged + CheckPeer !Peer + | -- | a peer process stopped + PeerDied !Child + | -- | the height of the best block changed + ManagerBest !BlockHeight + | -- | a peer acknowledged our version + PeerVerAck !Peer + | -- | a peer sent its version + PeerVersion !Peer !Version + | -- | a peer pinged us with a nonce + PeerPing !Peer !Word64 + | -- | a peer answered a ping with a nonce + PeerPong !Peer !Word64 + | -- | a peer relayed addresses + PeerAddrs !Peer ![NetworkAddress] + | -- | reply once every previous message has been handled + Sync !(Listen ()) -- | Data structure representing an online peer. +-- +-- Peers are compared for equality by their 'Peer' handle, and ordered by the +-- median of their recent ping times, so that sorting a list puts the fastest +-- peers first. Peers without any ping measurement sort as if their median ping +-- were 60 seconds. data OnlinePeer = OnlinePeer - { address :: !SockAddr, + { -- | network address of the peer + address :: !SockAddr, + -- | whether the peer acknowledged our version verack :: !Bool, + -- | whether the handshake is complete: both version and verack received online :: !Bool, + -- | version message sent by the peer, if received version :: !(Maybe Version), + -- | thread running the peer process async :: !(Async ()), + -- | handle to talk to the peer mailbox :: !Peer, + -- | nonce of the version message we sent, used to detect connections to + -- ourselves nonce :: !Word64, + -- | time and nonce of the ping awaiting an answer, if any ping :: !(Maybe (UTCTime, Word64)), + -- | round-trip times of the last eleven pings, sorted pings :: ![NominalDiffTime], + -- | when the connection was made connected :: !UTCTime, + -- | when the peer last sent a message tickled :: !UTCTime } @@ -117,6 +214,12 @@ where f OnlinePeer {pings = pings} = fromMaybe 60 (median pings) +-- | Start a peer manager and pass it to the given action. The peer manager and +-- all its peers are stopped when the action returns. +-- +-- The peer manager does not connect to any peer until it learns the height of +-- the best block through 'peerMgrBest'. "Haskoin.Node" does this as soon as the +-- chain is loaded. withPeerMgr :: (MonadUnliftIO m) => PeerMgrConfig -> @@ -143,6 +246,8 @@ go mgr ibx = withAsync (peerManager mgr ibx) $ \a -> withConnectLoop mgr (link a >> action mgr) +-- | Main loop of the peer manager process. Waits for the best block height, then +-- handles messages forever. peerManager :: (MonadUnliftIO m) => PeerMgr -> Inbox PeerMgrMessage -> m () peerManager mgr ibx = do @@ -154,25 +259,31 @@ logDebug mgr.config.logger "Awaiting event..." dispatch mgr =<< receive ibx +-- | Store the height of the best block. putBestBlock :: (MonadIO m) => PeerMgr -> BlockHeight -> m () putBestBlock mgr bb = atomically $ writeTVar mgr.best bb +-- | Read the height of the best block. getBestBlock :: (MonadIO m) => PeerMgr -> m BlockHeight getBestBlock mgr = readTVarIO mgr.best +-- | Network constants of the peer manager. getNetwork :: PeerMgr -> Network getNetwork mgr = mgr.config.net +-- | Add the static peers and, if discovery is on, the network seeds to the known addresses. loadPeers :: (MonadIO m) => PeerMgr -> m () loadPeers mgr = do loadStaticPeers mgr loadNetSeeds mgr +-- | Resolve the static peers in the configuration and add them to the known addresses. loadStaticPeers :: (MonadIO m) => PeerMgr -> m () loadStaticPeers mgr = mapM_ (newPeer mgr) . concat =<< mapM (liftIO . toSockAddr mgr.config.net) mgr.config.peers +-- | If discovery is on, resolve the DNS seeds of the network and add them to the known addresses. loadNetSeeds :: (MonadIO m) => PeerMgr -> m () loadNetSeeds mgr = when mgr.config.discover $ do @@ -181,6 +292,7 @@ <$> mapM (liftIO . toSockAddr mgr.config.net) mgr.config.net.seeds mapM_ (newPeer mgr) ss +-- | Log how many peers are online out of the maximum. logConnectedPeers :: (MonadIO m) => PeerMgr -> m () logConnectedPeers mgr = do let m = mgr.config.maxPeers @@ -189,15 +301,19 @@ mgr.config.logger ("Peers connected: " <> cs (show l) <> "/" <> cs (show m)) +-- | All peers being connected to or online, fastest first. getOnlinePeers :: (MonadIO m) => PeerMgr -> m [OnlinePeer] getOnlinePeers mgr = readTVarIO mgr.peers +-- | Peers that completed the handshake, fastest first. getConnectedPeers :: (MonadIO m) => PeerMgr -> m [OnlinePeer] getConnectedPeers mgr = filter (.online) <$> getOnlinePeers mgr +-- | Publish a peer event. managerEvent :: (MonadIO m) => PeerMgr -> PeerEvent -> m () managerEvent mgr e = publish e mgr.config.pub +-- | Handle a message sent to the peer manager. dispatch :: (MonadUnliftIO m) => PeerMgr -> PeerMgrMessage -> m () dispatch mgr (PeerVersion p v) = do @@ -273,12 +389,17 @@ logDebug mgr.config.logger ("Housekeeping for peer " <> p.label) checkPeer mgr p +-- | Record that a peer just sent a message, so that it is not disconnected for +-- being idle. "Haskoin.Node" calls this for every message received. ticklePeer :: (MonadIO m) => PeerMgr -> Peer -> m () ticklePeer mgr p = do logDebug mgr.config.logger ("Tickling peer " <> p.label) t <- liftIO getCurrentTime atomically (modifyPeer mgr.peers p (\o -> o {tickled = t})) +-- | Disconnect a peer that has been connected for too long, has been idle for +-- too long, or did not answer a ping in time. Otherwise ping it if no ping is +-- pending. checkPeer :: (MonadIO m) => PeerMgr -> Peer -> m () checkPeer mgr p = atomically (mgr.peers `findPeer` p) >>= \case @@ -303,6 +424,7 @@ Nothing -> do logError mgr.config.logger ("Peer " <> p.label <> " is offline") +-- | Send a ping with a random nonce to an online peer and remember when it was sent. sendPing :: (MonadIO m) => PeerMgr -> Peer -> m () sendPing mgr p = do atomically (mgr.peers `findPeer` p) >>= \case @@ -322,6 +444,7 @@ mgr.config.logger ("Will not ping offline peer " <> p.label) +-- | Clean up after a peer process stops, and publish a disconnection event if the peer was online. processPeerOffline :: (MonadIO m) => PeerMgr -> Child -> m () processPeerOffline mgr a = do atomically (findPeerAsync mgr.peers a) >>= \case @@ -340,6 +463,7 @@ atomically (removePeer mgr.peers o.mailbox) logConnectedPeers mgr +-- | Publish a connection event for a peer that just completed the handshake. announcePeer :: (MonadIO m) => PeerMgr -> Peer -> m () announcePeer mgr p = do atomically (findPeer mgr.peers p) >>= \case @@ -352,6 +476,7 @@ Nothing -> logWarn mgr.config.logger ("Not announcing disconnected peer " <> p.label) +-- | Take an address from the known addresses. If there are none, reload the static peers and seeds first. getNewPeer :: (MonadIO m) => PeerMgr -> m (Maybe SockAddr) getNewPeer mgr = g >>= \case @@ -364,6 +489,8 @@ mgr.addresses (first (listToMaybe . Set.elems) . Set.splitAt 1) +-- | Start a peer process for an address and send it our version, unless there +-- are no free slots or the address is already connected. connectPeer :: (MonadUnliftIO m) => PeerMgr -> SockAddr -> m () connectPeer mgr sa = do n <- length <$> getOnlinePeers mgr @@ -424,6 +551,8 @@ launch pc inbox p = withPeerLoop mgr p (\a -> link a >> peer pc p inbox) +-- | Run a loop in the background that asks the peer manager to check a peer at +-- random intervals between a quarter and a half of the timeout. withPeerLoop :: (MonadUnliftIO m) => PeerMgr -> Peer -> (Async a -> m a) -> m a withPeerLoop mgr p = withAsync . loopForever $ do @@ -433,6 +562,8 @@ threadDelay r managerCheck mgr p +-- | Run a loop in the background that connects to a new peer every 0.1 to 5 +-- seconds while there are free slots. withConnectLoop :: (MonadUnliftIO m) => PeerMgr -> m a -> m a withConnectLoop mgr act = withAsync go $ \a -> link a >> act @@ -450,6 +581,7 @@ maxKnownAddresses :: Int maxKnownAddresses = 4096 +-- | Add an address to the known addresses, unless it is connected already or the pool is full. newPeer :: (MonadIO m) => PeerMgr -> SockAddr -> m () newPeer mgr sa = atomically $ @@ -460,6 +592,7 @@ then known else Set.insert sa known +-- | Record the round-trip time of a ping if the nonce matches the pending one. gotPong :: TVar [OnlinePeer] -> Word64 -> UTCTime -> Peer -> STM () gotPong b nonce now p = findPeer b p >>= \case @@ -469,10 +602,17 @@ insertPeer b o' _ -> return () +-- | Remember the time and nonce of a ping sent to a peer. setPeerPing :: TVar [OnlinePeer] -> Word64 -> UTCTime -> Peer -> STM () setPeerPing b nonce now p = modifyPeer b p $ \o -> o {ping = Just (now, nonce)} +-- | Store the version of a peer. Returns 'Nothing' to reject it if the peer does +-- not serve the full chain, is ourselves, is unknown, or already sent a version. +-- +-- A peer must offer the full chain ('nodeNetwork') to be useful for syncing, and +-- a version whose nonce matches one of ours means the node has connected to +-- itself, which happens when it learns its own address from gossip. setPeerVersion :: TVar [OnlinePeer] -> Peer -> Version -> STM (Maybe OnlinePeer) setPeerVersion b p v | v.services .&. nodeNetwork == 0 = return Nothing @@ -490,6 +630,8 @@ insertPeer b n return (Just n) +-- | Record that a peer acknowledged our version. Returns 'Nothing' if the peer is +-- unknown or already sent one. setPeerVerAck :: TVar [OnlinePeer] -> Peer -> STM (Maybe OnlinePeer) setPeerVerAck b p = findPeer b p >>= \case @@ -500,57 +642,76 @@ return (Just o') Nothing -> return Nothing +-- | Find a peer in the list. findPeer :: TVar [OnlinePeer] -> Peer -> STM (Maybe OnlinePeer) findPeer b p = find ((== p) . (.mailbox)) <$> readTVar b +-- | Add or replace a peer in the list, keeping it sorted. insertPeer :: TVar [OnlinePeer] -> OnlinePeer -> STM () insertPeer b o = modifyTVar b $ \x -> sort . nub $ o : x +-- | Change a peer in the list, if it is there. modifyPeer :: TVar [OnlinePeer] -> Peer -> (OnlinePeer -> OnlinePeer) -> STM () modifyPeer b p f = findPeer b p >>= \case Nothing -> return () Just o -> insertPeer b $ f o +-- | Remove a peer from the list. removePeer :: TVar [OnlinePeer] -> Peer -> STM () removePeer b p = modifyTVar b (filter ((/= p) . (.mailbox))) +-- | Find a peer by the thread that runs it. findPeerAsync :: TVar [OnlinePeer] -> Async () -> STM (Maybe OnlinePeer) findPeerAsync b a = find ((== a) . (.async)) <$> readTVar b +-- | Find a peer by its address. findPeerAddress :: TVar [OnlinePeer] -> SockAddr -> STM (Maybe OnlinePeer) findPeerAddress b a = find ((== a) . (.address)) <$> readTVar b +-- | Peers that completed the handshake, sorted so that those with the lowest +-- median ping come first. getPeers :: (MonadIO m) => PeerMgr -> m [OnlinePeer] getPeers = getConnectedPeers +-- | Information about a peer, or 'Nothing' if the peer manager does not know it. +-- The peer may still be in the middle of the handshake; check 'online'. getOnlinePeer :: (MonadIO m) => PeerMgr -> Peer -> m (Maybe OnlinePeer) getOnlinePeer mgr p = atomically (mgr.peers `findPeer` p) +-- | Ask the peer manager to check a peer. managerCheck :: (MonadIO m) => PeerMgr -> Peer -> m () managerCheck mgr p = CheckPeer p `send` mgr.mailbox +-- | Ask the peer manager to connect to an address. managerConnect :: (MonadIO m) => PeerMgr -> SockAddr -> m () managerConnect mgr sa = Connect sa `send` mgr.mailbox +-- | Tell the peer manager the height of the best block. peerMgrBest :: (MonadIO m) => PeerMgr -> BlockHeight -> m () peerMgrBest mgr bh = ManagerBest bh `send` mgr.mailbox +-- | Tell the peer manager that a peer acknowledged our version. peerMgrVerAck :: (MonadIO m) => PeerMgr -> Peer -> m () peerMgrVerAck mgr p = PeerVerAck p `send` mgr.mailbox +-- | Tell the peer manager that a peer sent its version. peerMgrVersion :: (MonadIO m) => PeerMgr -> Peer -> Version -> m () peerMgrVersion mgr p ver = PeerVersion p ver `send` mgr.mailbox +-- | Tell the peer manager that a peer sent a ping, so that it answers with a pong. peerMgrPing :: (MonadIO m) => PeerMgr -> Peer -> Word64 -> m () peerMgrPing mgr p nonce = PeerPing p nonce `send` mgr.mailbox +-- | Tell the peer manager that a peer answered a ping. peerMgrPong :: (MonadIO m) => PeerMgr -> Peer -> Word64 -> m () peerMgrPong mgr p nonce = PeerPong p nonce `send` mgr.mailbox +-- | Tell the peer manager about addresses relayed by a peer. They are added to +-- the known addresses if discovery is on and they are routable. peerMgrAddrs :: (MonadIO m) => PeerMgr -> Peer -> [NetworkAddress] -> m () peerMgrAddrs mgr p addrs = PeerAddrs p addrs `send` mgr.mailbox @@ -585,6 +746,7 @@ | otherwise -> True isRoutable _ = False +-- | Whether an IPv4 address is public unicast. routable4 :: (Word8, Word8, Word8, Word8) -> Bool routable4 (a, b, c, _) | a == 0 = False -- this network @@ -602,6 +764,8 @@ | a >= 224 = False -- multicast and reserved | otherwise = True +-- | Split a peer address into host and port. Accepts @host@, @host:port@, +-- @[ipv6]@ and @[ipv6]:port@. Either part is 'Nothing' if missing. toHostService :: String -> (Maybe String, Maybe String) toHostService str = let host = case m6 of @@ -626,6 +790,9 @@ _ -> Nothing in (host, srv) +-- | Resolve a peer address given as in 'toHostService' into socket addresses, +-- using the default port of the network if none is given. Returns an empty list +-- if it cannot be resolved. toSockAddr :: Network -> String -> IO [SockAddr] toSockAddr net str = go `catch` e @@ -637,6 +804,7 @@ e :: (Monad m) => SomeException -> m [SockAddr] e _ = return [] +-- | Median of a list, or 'Nothing' if it is empty. median :: (Ord a, Fractional a) => [a] -> Maybe a median ls | null ls = @@ -649,6 +817,9 @@ where ls' = sort ls +-- | Build our version message from the network, a random nonce, the best block +-- height, our address, the remote address and the current time in seconds since +-- the Unix epoch. buildVersion :: Network -> Word64 -> @@ -673,5 +844,6 @@ relay = True } +-- | Protocol version that the node speaks. myVersion :: Word32 myVersion = 70012