haskoin-node 2.3.0 → 2.3.1

raw patch · 9 files changed

+1080/−57 lines, 9 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +10/−0
• README.md +502/−2
• haskoin-node.cabal +1/−1
• src/Haskoin/Node.hs +141/−10
• src/Haskoin/Node/Chain.hs +119/−16
• src/Haskoin/Node/Logger.hs +23/−3
• src/Haskoin/Node/Loop.hs +2/−0
• src/Haskoin/Node/Peer.hs +97/−12
• src/Haskoin/Node/PeerMgr.hs +185/−13

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

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

@@ -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 <https://github.com/jprupp/haskoin-node#readme> category:       Bitcoin, Finance, Network

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

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

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

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

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

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