├── .gitignore ├── .hindent.yaml ├── CHANGELOG.md ├── LICENSE ├── README.md ├── Setup.hs ├── haskoin-node.cabal ├── hie.yaml ├── package.yaml ├── scripts └── format ├── src └── Haskoin │ ├── Node.hs │ └── Node │ ├── Chain.hs │ ├── Peer.hs │ └── PeerMgr.hs ├── stack.yaml ├── stack.yaml.lock └── test ├── Haskoin └── NodeSpec.hs └── Spec.hs /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | *.dyn_o 9 | *.dyn_hi 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox/ 13 | cabal.sandbox.config 14 | *.prof 15 | *.aux 16 | *.hp 17 | *.eventlog 18 | .stack-work/ 19 | cabal.project.local 20 | cabal.project.local~ 21 | .HTF/ 22 | .ghc.environment.* 23 | TAGS -------------------------------------------------------------------------------- /.hindent.yaml: -------------------------------------------------------------------------------- 1 | indent-size: 4 2 | line-length: 80 3 | force-trailing-newline: true 4 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Changelog 2 | All notable changes to this project will be documented in this file. 3 | 4 | The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/) 5 | and this project adheres to [Semantic Versioning](http://semver.org/spec/v2.0.0.html). 6 | 7 | ## [1.1.4] - 2025-05-08 8 | 9 | ### Changed 10 | 11 | - Move to personal repository. 12 | 13 | ## [1.1.3] - 2024-05-23 14 | 15 | ### Fixed 16 | 17 | - Tickle a peer whenever a message is received. 18 | 19 | ## [1.1.2] - 2024-05-23 20 | 21 | ### Fixed 22 | 23 | - Correct log messages from peer manager. 24 | 25 | ## [1.1.1] - 2024-05-23 26 | 27 | ### Fixed 28 | 29 | - Peers timeout more aggressively. 30 | 31 | ## [1.1.0] - 2024-03-14 32 | 33 | ### Changed 34 | 35 | - Update LTS Haskell & upstream dependencies. 36 | 37 | ## [1.0.1] - 2023-08-03 38 | 39 | ### Changed 40 | 41 | - Add compatibility with latest LTS Haskell. 42 | 43 | ## [1.0.0] - 2023-07-28 44 | 45 | ### Changed 46 | 47 | - Make compatible with latest haskoin-core. 48 | - Use DuplicateRecordFields and OverloadedRecordDot. 49 | - Simplify pub/sub queues. 50 | - Multiple refactoring passes. 51 | 52 | ## [0.18.1] - 2022-07-27 53 | 54 | ### Fixed 55 | 56 | - Set default port for peers where it is unset. 57 | 58 | ## [0.18.0] - 2022-07-27 59 | 60 | ### Added 61 | 62 | - Support setting up and connecting to IPv6 peers. 63 | 64 | ## [0.17.14] - 2021-08-14 65 | 66 | ### Fixed 67 | 68 | - Reduce verbosity on incoming header decode test. 69 | - Show appropriate error message upon receiving empty headers. 70 | 71 | ## [0.17.13] - 2021-08-14 72 | 73 | ### Added 74 | 75 | - Display more details about invalid incoming headers. 76 | 77 | ## [0.17.12] - 2021-05-17 78 | 79 | ### Fixed 80 | 81 | - Do not connect to more than the maximum number of peers. 82 | 83 | ## [0.17.11] - 2021-05-17 84 | 85 | ### Added 86 | 87 | - Display message command that disconnects a peer. 88 | 89 | ## [0.17.10] - 2021-05-17 90 | 91 | ### Fixed 92 | 93 | - Correct disconnect timeout algorithm bug. 94 | 95 | ## [0.17.9] - 2021-05-17 96 | 97 | ### Fixed 98 | 99 | - Add randomised timeouts to avoid disconnecting all peers. 100 | 101 | ## [0.17.2] - 2021-03-09 102 | 103 | ### Fixed 104 | 105 | - Do not start chain actor until database initialized. 106 | 107 | ## [0.17.1] - 2021-01-08 108 | 109 | ### Changed 110 | 111 | - Depend on haskoin-core-0.17.3. 112 | 113 | ## [0.17.0] - 2020-10-21 114 | 115 | ### Added 116 | 117 | - Support for Bitcoin Cash November 2020 hard fork. 118 | - BlockHeaders instance for ReaderT Chain. 119 | 120 | ## [0.16.0] - 2020-07-23 121 | 122 | ### Changed 123 | 124 | - Add support for column families. 125 | 126 | ## [0.15.0] - 2020-07-20 127 | 128 | ### Changed 129 | 130 | - Use new Haskell bindings for RocksDB. 131 | 132 | ## [0.14.1] - 2020-06-19 133 | 134 | ### Fixed 135 | 136 | - Correct flawed peer locking logic in Chain actor. 137 | 138 | ## [0.14.0] - 2020-06-18 139 | 140 | ### Changed 141 | 142 | - Massively refactor everything in a non-backwards-compatible way. 143 | - Use MIT license. 144 | - Bump haskoin-core. 145 | - Bump secp256k1-haskell. 146 | 147 | ### Fixed 148 | 149 | - Fix getting stuck on a single peer. 150 | 151 | ## [0.13.0] - 2020-05-08 152 | 153 | ### Changed 154 | 155 | - Depend on Haskoin Store 0.13.3. 156 | - Better code organisation. 157 | 158 | ## [0.12.0] - 2020-05-06 159 | 160 | ### Changed 161 | 162 | - Add a test suite that simulates network instead of connecting to real one. 163 | 164 | ## [0.11.3] - 2020-05-03 165 | 166 | ### Changed 167 | 168 | - Revert including multiline decoding error text in logs. 169 | 170 | ## [0.11.2] - 2020-05-03 171 | 172 | ### Changed 173 | 174 | - Include header decoding error text in logs. 175 | 176 | ## [0.11.1] - 2020-05-03 177 | 178 | ### Changed 179 | 180 | - Improve logging. 181 | 182 | ## [0.11.0] - 2020-05-03 183 | 184 | ### Changed 185 | 186 | - Set peer too old time 187 | 188 | ## [0.10.1] - 2020-05-03 189 | 190 | ### Changed 191 | 192 | - Disconnect old peers after 48 hours instead of 30 minutes. 193 | 194 | ## [0.10.0] - 2020-05-03 195 | 196 | ### Changed 197 | 198 | - Move modules out of Network.Haskoin namespace. 199 | - Add better and more logging. 200 | - Change Manager module name and related values to PeerManager. 201 | 202 | ## [0.9.21] - 2020-04-07 203 | 204 | ### Removed 205 | 206 | - Remove unnecessary logging. 207 | 208 | ## [0.9.20] - 2020-04-07 209 | 210 | ### Changed 211 | 212 | - Better log messages. 213 | - Less verbose debug logging. 214 | 215 | ## [0.9.19] - 2020-04-07 216 | 217 | ### Changed 218 | - Better log messages. 219 | 220 | ## [0.9.18] - 2020-04-07 221 | 222 | ### Added 223 | 224 | - More aggressive peer discovery. 225 | 226 | ## [0.9.17] - 2020-04-07 227 | 228 | ### Added 229 | 230 | - Peers are disconnected automatically after awhile. 231 | 232 | ## [0.9.16] - 2020-02-08 233 | 234 | ### Added 235 | 236 | - Lower bound versions for some dependencies. 237 | 238 | ## [0.9.15] - 2020-01-15 239 | 240 | ### Changed 241 | 242 | - Update to support new `NetworkAddress` data structure from `haskoin-core`. 243 | 244 | ## [0.9.14] - 2019-12-10 245 | 246 | ### Removed 247 | 248 | - No longer support storing peers in db as performance tradeoff doesn't justify it. 249 | 250 | ## [0.9.13] - 2019-10-08 251 | 252 | ### Changed 253 | 254 | - Really store peers in db. 255 | 256 | ## [0.9.12] - 2019-10-08 257 | 258 | ### Changed 259 | 260 | - Demote some logging to debug level. 261 | 262 | ## [0.9.11] - 2019-10-02 263 | 264 | ### Added 265 | 266 | - Add `-O2` optimisations to GHC. 267 | 268 | ## [0.9.10] - 2019-04-19 269 | 270 | ### Added 271 | 272 | - Increase debugging information where application freezes. 273 | 274 | ## [0.9.9] - 2019-04-12 275 | 276 | ### Added 277 | 278 | - Increase debugging information. 279 | 280 | ## [0.9.8] - 2019-04-12 281 | 282 | ### Changed 283 | 284 | - Increase version of haskoin-core to 0.9.0. 285 | - Fix some tests. 286 | 287 | ## [0.9.7] - 2019-04-12 288 | 289 | ### Added 290 | 291 | - More debugging. 292 | 293 | ### Changed 294 | 295 | - Be defensive against duplicate peers. 296 | - Increase interval between housekeeping pings. 297 | - Replace peers in database atomically. 298 | 299 | ## [0.9.6] - 2019-04-01 300 | 301 | ### Changed 302 | 303 | - Randomize known peers instead of keeping scores. 304 | - Simplify peer management code to avoid freezes. 305 | - Merge logic for chain and manager. 306 | 307 | ## [0.9.5] - 2018-11-14 308 | 309 | ### Changed 310 | 311 | - Do not record new peers in database when peer discovery is disabled. 312 | 313 | ## [0.9.4] - 2018-11-01 314 | 315 | ### Changed 316 | 317 | - Don't spam best block events. 318 | 319 | ## [0.9.3] - 2018-10-22 320 | 321 | ### Changed 322 | 323 | - Correct display of milliseconds in log. 324 | - Correct bug when receiving headers from unknown peer. 325 | - Simplify chain syncing code. 326 | 327 | ## [0.9.2] - 2018-10-18 328 | 329 | ### Changed 330 | 331 | - Peer dies immediately when receiving a bad message. 332 | 333 | ## [0.9.1] - 2018-10-18 334 | 335 | ### Changed 336 | 337 | - Keep track of last synced header from a peer to avoid endless loops on large reorgs. 338 | 339 | ## [0.9.0] - 2018-10-17 340 | 341 | ### Changed 342 | 343 | - Use an STM listener instead of a publisher for the node API. 344 | 345 | ## [0.8.2] - 2018-10-17 346 | 347 | ### Added 348 | 349 | - Expose `ChainMessage` and `ManagerMessage` types from `Haskoin.Node` module. 350 | 351 | ## [0.8.1] - 2018-10-11 352 | 353 | ### Changed 354 | 355 | - Corrected documentation for `killPeer` function. 356 | - Leave time out of logic code. 357 | 358 | ## [0.8.0] - 2018-10-09 359 | 360 | ### Changed 361 | 362 | - Peers are now killed directly instead of through peer manager. 363 | 364 | ### Removed 365 | 366 | - Chain no longer needs peer manager. 367 | 368 | ## [0.7.2] - 2018-10-09 369 | 370 | ### Added 371 | 372 | - Compatibility with base 4.12. 373 | 374 | ### Changed 375 | 376 | - Update base to 4.9. 377 | 378 | ## [0.7.1] - 2018-10-09 379 | 380 | ### Added 381 | 382 | - Allow to easily obtain a peer's publisher. 383 | 384 | ## [0.7.0] - 2018-10-09 385 | 386 | ### Added 387 | 388 | - Versioning for chain and peer database. 389 | - Automatic purging of chain and peer database when version changes. 390 | - Add extra timers. 391 | - Add publishers to every peer. 392 | 393 | ### Changed 394 | 395 | - Full reimplementation of node API. 396 | - Simplify peer selection and management. 397 | - Merge manager and peer events. 398 | - Rename configuration variables for node. 399 | - Separate logic from actors for peer manager and chain. 400 | 401 | ### Removed 402 | 403 | - Remove irrelevant fields from peer information. 404 | - Remove unreliable peer block head tracking. 405 | - Remove dependency on deprecated binary conduits. 406 | - Remove Bloom filter support from manager. 407 | - Remove unreliable peer request tracking code. 408 | - Remove separate manager events. 409 | 410 | ## [0.6.1] - 2018-09-14 411 | 412 | ### Changed 413 | 414 | - Fix bug where peer height did not update in certain cases. 415 | 416 | ## [0.6.0] - 2018-09-14 417 | 418 | ### Added 419 | 420 | - Documentation everywhere. 421 | 422 | ### Changed 423 | 424 | - Make compatible with NQE 0.5. 425 | - Use supervisor only in peer manager. 426 | - API quality of life changes. 427 | - Exposed module is now only `Haskoin.Node`. 428 | 429 | ### Removed 430 | 431 | - No more direct access to internals. 432 | 433 | ## [0.5.2] - 2018-09-10 434 | 435 | ### Changed 436 | 437 | - Improve dependency definitions. 438 | 439 | ## [0.5.1] - 2018-09-10 440 | 441 | ### Changed 442 | 443 | - Dependency `sec256k1` changes to `secp256k1-haskell`. 444 | 445 | ## [0.5.0] - 2018-09-09 446 | 447 | ### Added 448 | 449 | - New `CHANGELOG.md` file. 450 | - Use `nqe` for concurrency. 451 | - Peer discovery. 452 | - RocksDB peer and block header storage. 453 | - Support for Merkle blocks. 454 | 455 | ### Changed 456 | 457 | - Split out of former `haskoin` repository. 458 | - Use hpack and `package.yaml`. 459 | - Old `haskoin-node` package now renamed to `old-haskoin-node` and deprecated. 460 | 461 | ### Removed 462 | 463 | - Removed Old Haskoin Node package completely. 464 | - Removed Stylish Haskell configuration file. 465 | - Remvoed `haskoin-core` and `haskoin-wallet` packages from this repository. 466 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2020 Haskoin Developers 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy of 4 | this software and associated documentation files (the "Software"), to deal in 5 | the Software without restriction, including without limitation the rights to 6 | use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of 7 | the Software, and to permit persons to whom the Software is furnished to do so, 8 | subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be included in all 11 | copies or substantial portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS 15 | FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR 16 | COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER 17 | IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN 18 | CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 19 | 20 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Haskoin Node 2 | 3 | Haskoin Node is a peer-to-peer library for Bitcoin and Bitcoin Cash. It uses a 4 | RocksDB database to store blockchain headers and peers. 5 | 6 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /haskoin-node.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.38.0. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | -- 7 | -- hash: 0ae2d590b665e1063c502d7cb80a6eb8a01540512190560089f88f2642aa8a7d 8 | 9 | name: haskoin-node 10 | version: 1.1.4 11 | synopsis: P2P library for Bitcoin and Bitcoin Cash 12 | description: Please see the README on GitHub at 13 | category: Bitcoin, Finance, Network 14 | homepage: http://github.com/jprupp/haskoin-node#readme 15 | bug-reports: http://github.com/jprupp/haskoin-node/issues 16 | author: JP Rupp 17 | maintainer: jprupp@protonmail.ch 18 | license: MIT 19 | license-file: LICENSE 20 | build-type: Simple 21 | extra-source-files: 22 | README.md 23 | CHANGELOG.md 24 | 25 | source-repository head 26 | type: git 27 | location: https://github.com/jprupp/haskoin-node.git 28 | 29 | library 30 | exposed-modules: 31 | Haskoin.Node 32 | other-modules: 33 | Haskoin.Node.Chain 34 | Haskoin.Node.Peer 35 | Haskoin.Node.PeerMgr 36 | Paths_haskoin_node 37 | hs-source-dirs: 38 | src 39 | build-depends: 40 | base >=4.9 && <5 41 | , bytestring 42 | , cereal 43 | , conduit 44 | , conduit-extra 45 | , containers 46 | , data-default 47 | , hashable 48 | , haskoin-core >=1.0.0 49 | , monad-logger 50 | , mtl 51 | , network 52 | , nqe >=0.6.3 53 | , random 54 | , resourcet 55 | , rocksdb-haskell-jprupp >=2.1.2 56 | , rocksdb-query >=0.4.2 57 | , string-conversions 58 | , text 59 | , time 60 | , transformers 61 | , unliftio 62 | , unordered-containers 63 | default-language: Haskell2010 64 | 65 | test-suite spec 66 | type: exitcode-stdio-1.0 67 | main-is: Spec.hs 68 | other-modules: 69 | Haskoin.NodeSpec 70 | Paths_haskoin_node 71 | hs-source-dirs: 72 | test 73 | build-depends: 74 | HUnit 75 | , base >=4.9 && <5 76 | , base64 77 | , bytestring 78 | , cereal 79 | , conduit 80 | , conduit-extra 81 | , containers 82 | , data-default 83 | , hashable 84 | , haskoin-core >=1.0.0 85 | , haskoin-node 86 | , hspec 87 | , monad-logger 88 | , mtl 89 | , network 90 | , nqe >=0.6.3 91 | , random 92 | , resourcet 93 | , rocksdb-haskell-jprupp >=2.1.2 94 | , rocksdb-query >=0.4.2 95 | , safe 96 | , string-conversions 97 | , text 98 | , time 99 | , transformers 100 | , unliftio 101 | , unordered-containers 102 | default-language: Haskell2010 103 | build-tool-depends: hspec-discover:hspec-discover 104 | -------------------------------------------------------------------------------- /hie.yaml: -------------------------------------------------------------------------------- 1 | cradle: 2 | stack: 3 | - path: "./src" 4 | component: haskoin-node:lib 5 | - path: "./test" 6 | component: haskoin-node:test:spec -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: haskoin-node 2 | version: 1.1.4 3 | synopsis: P2P library for Bitcoin and Bitcoin Cash 4 | description: Please see the README on GitHub at 5 | category: Bitcoin, Finance, Network 6 | author: JP Rupp 7 | maintainer: jprupp@protonmail.ch 8 | license: MIT 9 | license-file: LICENSE 10 | github: jprupp/haskoin-node.git 11 | homepage: http://github.com/jprupp/haskoin-node#readme 12 | bug-reports: http://github.com/jprupp/haskoin-node/issues 13 | extra-source-files: 14 | - README.md 15 | - CHANGELOG.md 16 | dependencies: 17 | - base >=4.9 && <5 18 | - bytestring 19 | - cereal 20 | - conduit 21 | - conduit-extra 22 | - containers 23 | - data-default 24 | - hashable 25 | - haskoin-core >= 1.0.0 26 | - monad-logger 27 | - mtl 28 | - network 29 | - nqe >= 0.6.3 30 | - random 31 | - resourcet 32 | - rocksdb-haskell-jprupp >= 2.1.2 33 | - rocksdb-query >= 0.4.2 34 | - string-conversions 35 | - text 36 | - transformers 37 | - time 38 | - unliftio 39 | - unordered-containers 40 | library: 41 | source-dirs: src 42 | exposed-modules: 43 | - Haskoin.Node 44 | tests: 45 | spec: 46 | main: Spec.hs 47 | source-dirs: test 48 | verbatim: 49 | build-tool-depends: 50 | hspec-discover:hspec-discover 51 | dependencies: 52 | - base64 53 | - hspec 54 | - haskoin-node 55 | - HUnit 56 | - safe 57 | -------------------------------------------------------------------------------- /scripts/format: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | find src -type f -name "*.hs" | xargs ormolu -i 4 | find test -type f -name "*.hs" | xargs ormolu -i 5 | -------------------------------------------------------------------------------- /src/Haskoin/Node.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DuplicateRecordFields #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE LambdaCase #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE OverloadedRecordDot #-} 7 | {-# LANGUAGE RecordWildCards #-} 8 | {-# LANGUAGE NoFieldSelectors #-} 9 | 10 | module Haskoin.Node 11 | ( module Haskoin.Node.Peer, 12 | module Haskoin.Node.PeerMgr, 13 | module Haskoin.Node.Chain, 14 | NodeConfig (..), 15 | NodeEvent (..), 16 | Node (..), 17 | withNode, 18 | withConnection, 19 | ) 20 | where 21 | 22 | import Control.Monad (forever) 23 | import Control.Monad.Cont (ContT (..), MonadCont (callCC), cont, runCont, runContT) 24 | import Control.Monad.Logger (MonadLoggerIO) 25 | import Control.Monad.Trans (lift) 26 | import Data.Conduit.Network 27 | ( ClientSettings, 28 | appSink, 29 | appSource, 30 | clientSettings, 31 | runTCPClient, 32 | ) 33 | import Data.String.Conversions (cs) 34 | import Data.Time.Clock (NominalDiffTime) 35 | import Database.RocksDB (ColumnFamily, DB) 36 | import Haskoin 37 | ( Addr (..), 38 | BlockNode (..), 39 | Headers (..), 40 | Message (..), 41 | Network, 42 | NetworkAddress, 43 | Ping (..), 44 | Pong (..), 45 | ) 46 | import Haskoin.Node.Chain 47 | import Haskoin.Node.Peer 48 | import Haskoin.Node.PeerMgr 49 | import NQE 50 | ( Inbox, 51 | Publisher, 52 | publish, 53 | receive, 54 | withPublisher, 55 | withSubscription, 56 | ) 57 | import Network.Socket 58 | ( NameInfoFlag (..), 59 | SockAddr, 60 | getNameInfo, 61 | ) 62 | import Text.Read (readMaybe) 63 | import UnliftIO 64 | ( MonadUnliftIO, 65 | SomeException, 66 | catch, 67 | liftIO, 68 | link, 69 | throwIO, 70 | withAsync, 71 | ) 72 | 73 | -- | General node configuration. 74 | data NodeConfig = NodeConfig 75 | { -- | maximum number of connected peers allowed 76 | maxPeers :: !Int, 77 | -- | database handler 78 | db :: !DB, 79 | -- | database column family 80 | cf :: !(Maybe ColumnFamily), 81 | -- | static list of peers to connect to 82 | peers :: ![String], 83 | -- | activate peer discovery 84 | discover :: !Bool, 85 | -- | network address for the local host 86 | address :: !NetworkAddress, 87 | -- | network constants 88 | net :: !Network, 89 | -- | node events are sent to this publisher 90 | pub :: !(Publisher NodeEvent), 91 | -- | timeout in seconds 92 | timeout :: !NominalDiffTime, 93 | -- | peer disconnect after seconds 94 | maxPeerLife :: !NominalDiffTime, 95 | connect :: !(SockAddr -> WithConnection) 96 | } 97 | 98 | data Node = Node 99 | { peerMgr :: !PeerMgr, 100 | chain :: !Chain 101 | } 102 | 103 | data NodeEvent 104 | = ChainEvent !ChainEvent 105 | | PeerEvent !PeerEvent 106 | deriving (Eq) 107 | 108 | withConnection :: SockAddr -> WithConnection 109 | withConnection na f = 110 | fromSockAddr na >>= \case 111 | Nothing -> throwIO PeerAddressInvalid 112 | Just cset -> 113 | runTCPClient cset $ \ad -> 114 | f (Conduits (appSource ad) (appSink ad)) 115 | 116 | fromSockAddr :: 117 | (MonadUnliftIO m) => SockAddr -> m (Maybe ClientSettings) 118 | fromSockAddr sa = go `catch` e 119 | where 120 | go = do 121 | (maybe_host, maybe_port) <- liftIO (getNameInfo flags True True sa) 122 | return $ 123 | clientSettings 124 | <$> (readMaybe =<< maybe_port) 125 | <*> (cs <$> maybe_host) 126 | flags = [NI_NUMERICHOST, NI_NUMERICSERV] 127 | e :: (Monad m) => SomeException -> m (Maybe a) 128 | e _ = return Nothing 129 | 130 | chainEvents :: 131 | (MonadUnliftIO m, MonadLoggerIO m) => 132 | PeerMgr -> 133 | Inbox ChainEvent -> 134 | Publisher NodeEvent -> 135 | m () 136 | chainEvents mgr input output = forever $ do 137 | event <- receive input 138 | case event of 139 | ChainBestBlock bb -> 140 | peerMgrBest bb.height mgr 141 | _ -> return () 142 | publish (ChainEvent event) output 143 | 144 | peerEvents :: 145 | (MonadUnliftIO m, MonadLoggerIO m) => 146 | Chain -> 147 | PeerMgr -> 148 | Inbox PeerEvent -> 149 | Publisher NodeEvent -> 150 | m () 151 | peerEvents ch mgr input output = forever $ do 152 | event <- receive input 153 | case event of 154 | PeerConnected p -> 155 | chainPeerConnected p ch 156 | PeerDisconnected p -> 157 | chainPeerDisconnected p ch 158 | PeerMessage p msg -> do 159 | case msg of 160 | MVersion v -> 161 | peerMgrVersion p v mgr 162 | MVerAck -> 163 | peerMgrVerAck p mgr 164 | MPing (Ping n) -> 165 | peerMgrPing p n mgr 166 | MPong (Pong n) -> 167 | peerMgrPong p n mgr 168 | MAddr (Addr ns) -> 169 | peerMgrAddrs p (map snd ns) mgr 170 | MHeaders (Headers hs) -> 171 | chainHeaders p (map fst hs) ch 172 | _ -> return () 173 | ticklePeer mgr p 174 | publish (PeerEvent event) output 175 | 176 | -- | Launch node process in the foreground. 177 | withNode :: 178 | (MonadLoggerIO m, MonadUnliftIO m) => 179 | NodeConfig -> 180 | (Node -> m a) -> 181 | m a 182 | withNode NodeConfig {..} action = flip runContT return $ do 183 | peerPub <- ContT withPublisher 184 | peerSub <- ContT (withSubscription peerPub) 185 | chainPub <- ContT withPublisher 186 | chainSub <- ContT (withSubscription chainPub) 187 | let peerMgrCfg = PeerMgrConfig {pub = peerPub, ..} 188 | let chainCfg = ChainConfig {pub = chainPub, ..} 189 | chain <- ContT (withChain chainCfg) 190 | peerMgr <- ContT $ withPeerMgr peerMgrCfg 191 | lift . link =<< ContT (withAsync $ chainEvents peerMgr chainSub pub) 192 | lift . link =<< ContT (withAsync $ peerEvents chain peerMgr peerSub pub) 193 | lift $ action Node {..} 194 | -------------------------------------------------------------------------------- /src/Haskoin/Node/Chain.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE DuplicateRecordFields #-} 3 | {-# LANGUAGE ExistentialQuantification #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE LambdaCase #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE OverloadedRecordDot #-} 9 | {-# LANGUAGE OverloadedStrings #-} 10 | {-# LANGUAGE RecordWildCards #-} 11 | {-# LANGUAGE TemplateHaskell #-} 12 | {-# LANGUAGE UndecidableInstances #-} 13 | {-# LANGUAGE NoFieldSelectors #-} 14 | {-# OPTIONS_GHC -fno-warn-orphans #-} 15 | 16 | module Haskoin.Node.Chain 17 | ( ChainConfig (..), 18 | ChainEvent (..), 19 | Chain, 20 | withChain, 21 | chainGetBlock, 22 | chainGetBest, 23 | chainGetAncestor, 24 | chainGetParents, 25 | chainGetSplitBlock, 26 | chainPeerConnected, 27 | chainPeerDisconnected, 28 | chainIsSynced, 29 | chainBlockMain, 30 | chainHeaders, 31 | ) 32 | where 33 | 34 | import Control.Monad (forM_, forever, guard, when) 35 | import Control.Monad.Except (runExceptT, throwError) 36 | import Control.Monad.Logger 37 | ( MonadLoggerIO, 38 | logDebugS, 39 | logErrorS, 40 | logInfoS, 41 | ) 42 | import Control.Monad.Reader 43 | ( MonadReader, 44 | ReaderT (..), 45 | asks, 46 | runReaderT, 47 | ) 48 | import Control.Monad.Trans (lift) 49 | import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) 50 | import qualified Data.ByteString as B 51 | import Data.Function (on) 52 | import Data.List (delete, nub) 53 | import Data.Maybe (isJust, isNothing) 54 | import Data.Serialize 55 | ( Serialize, 56 | get, 57 | getWord8, 58 | put, 59 | putWord8, 60 | ) 61 | import Data.String.Conversions (cs) 62 | import Data.Time.Clock 63 | ( NominalDiffTime, 64 | UTCTime, 65 | diffUTCTime, 66 | getCurrentTime, 67 | ) 68 | import Data.Time.Clock.POSIX 69 | ( posixSecondsToUTCTime, 70 | utcTimeToPOSIXSeconds, 71 | ) 72 | import Data.Word (Word32) 73 | import Database.RocksDB (ColumnFamily, DB) 74 | import qualified Database.RocksDB as R 75 | import Database.RocksDB.Query 76 | ( Key, 77 | KeyValue, 78 | insert, 79 | insertCF, 80 | insertOp, 81 | insertOpCF, 82 | retrieveCommon, 83 | writeBatch, 84 | ) 85 | import Haskoin 86 | ( BlockHash, 87 | BlockHeader (..), 88 | BlockHeaders (..), 89 | BlockHeight, 90 | BlockNode (..), 91 | GetHeaders (..), 92 | Message (..), 93 | Network, 94 | blockLocator, 95 | connectBlocks, 96 | genesisNode, 97 | getAncestor, 98 | headerHash, 99 | splitPoint, 100 | ) 101 | import Haskoin.Node.Peer 102 | import Haskoin.Node.PeerMgr (myVersion) 103 | import NQE 104 | ( Mailbox, 105 | Publisher, 106 | newMailbox, 107 | publish, 108 | receive, 109 | send, 110 | ) 111 | import System.Random (randomRIO) 112 | import UnliftIO 113 | ( MonadIO, 114 | MonadUnliftIO, 115 | TVar, 116 | atomically, 117 | liftIO, 118 | link, 119 | modifyTVar, 120 | newTVarIO, 121 | readTVar, 122 | readTVarIO, 123 | withAsync, 124 | writeTVar, 125 | ) 126 | import UnliftIO.Concurrent (threadDelay) 127 | 128 | -- | Mailbox for chain header syncing process. 129 | data Chain = Chain 130 | { mailbox :: !(Mailbox ChainMessage), 131 | reader :: !ChainReader 132 | } 133 | 134 | instance Eq Chain where 135 | (==) = (==) `on` (.mailbox) 136 | 137 | -- | Configuration for chain syncing process. 138 | data ChainConfig = ChainConfig 139 | { -- | database handle 140 | db :: !DB, 141 | -- | column family 142 | cf :: !(Maybe ColumnFamily), 143 | -- | network constants 144 | net :: !Network, 145 | -- | send header chain events here 146 | pub :: !(Publisher ChainEvent), 147 | -- | timeout in seconds 148 | timeout :: !NominalDiffTime 149 | } 150 | 151 | data ChainMessage 152 | = ChainHeaders !Peer ![BlockHeader] 153 | | ChainPeerConnected !Peer 154 | | ChainPeerDisconnected !Peer 155 | | ChainPing 156 | 157 | -- | Events originating from chain syncing process. 158 | data ChainEvent 159 | = -- | chain has new best block 160 | ChainBestBlock !BlockNode 161 | | -- | chain is in sync with the network 162 | ChainSynced !BlockNode 163 | deriving (Eq, Show) 164 | 165 | type MonadChain m = 166 | ( MonadLoggerIO m, 167 | MonadUnliftIO m, 168 | MonadReader ChainReader m 169 | ) 170 | 171 | -- | State and configuration. 172 | data ChainReader = ChainReader 173 | { -- | placeholder for upstream data 174 | config :: !ChainConfig, 175 | -- | mutable state for header synchronization 176 | state :: !(TVar ChainState) 177 | } 178 | 179 | -- | Database key for version. 180 | data ChainDataVersionKey = ChainDataVersionKey 181 | deriving (Eq, Ord, Show) 182 | 183 | instance Key ChainDataVersionKey 184 | 185 | instance KeyValue ChainDataVersionKey Word32 186 | 187 | instance Serialize ChainDataVersionKey where 188 | get = do 189 | guard . (== 0x92) =<< getWord8 190 | return ChainDataVersionKey 191 | put ChainDataVersionKey = putWord8 0x92 192 | 193 | data ChainSync = ChainSync 194 | { peer :: !Peer, 195 | timestamp :: !UTCTime, 196 | best :: !(Maybe BlockNode) 197 | } 198 | 199 | -- | Mutable state for the header chain process. 200 | data ChainState = ChainState 201 | { -- | peer to sync against and time of last received message 202 | syncing :: !(Maybe ChainSync), 203 | -- | queue of peers to sync against 204 | peers :: ![Peer], 205 | -- | has the header chain ever been considered synced? 206 | beenInSync :: !Bool 207 | } 208 | 209 | -- | Key for block header in database. 210 | newtype BlockHeaderKey = BlockHeaderKey BlockHash deriving (Eq, Show) 211 | 212 | instance Serialize BlockHeaderKey where 213 | get = do 214 | guard . (== 0x90) =<< getWord8 215 | BlockHeaderKey <$> get 216 | put (BlockHeaderKey bh) = do 217 | putWord8 0x90 218 | put bh 219 | 220 | -- | Key for best block in database. 221 | data BestBlockKey = BestBlockKey deriving (Eq, Show) 222 | 223 | instance KeyValue BlockHeaderKey BlockNode 224 | 225 | instance KeyValue BestBlockKey BlockNode 226 | 227 | instance Serialize BestBlockKey where 228 | get = do 229 | guard . (== 0x91) =<< getWord8 230 | return BestBlockKey 231 | put BestBlockKey = putWord8 0x91 232 | 233 | instance (MonadIO m) => BlockHeaders (ReaderT ChainConfig m) where 234 | addBlockHeader bn = do 235 | db <- asks (.db) 236 | asks (.cf) >>= \case 237 | Nothing -> insert db (BlockHeaderKey h) bn 238 | Just cf -> insertCF db cf (BlockHeaderKey h) bn 239 | where 240 | h = headerHash bn.header 241 | getBlockHeader bh = do 242 | db <- asks (.db) 243 | mcf <- asks (.cf) 244 | retrieveCommon db mcf (BlockHeaderKey bh) 245 | getBestBlockHeader = do 246 | db <- asks (.db) 247 | mcf <- asks (.cf) 248 | retrieveCommon db mcf BestBlockKey >>= \case 249 | Nothing -> error "Could not get best block from database" 250 | Just b -> return b 251 | setBestBlockHeader bn = do 252 | db <- asks (.db) 253 | asks (.cf) >>= \case 254 | Nothing -> insert db BestBlockKey bn 255 | Just cf -> insertCF db cf BestBlockKey bn 256 | addBlockHeaders bns = do 257 | db <- asks (.db) 258 | mcf <- asks (.cf) 259 | writeBatch db (map (f mcf) bns) 260 | where 261 | h bn = headerHash bn.header 262 | f Nothing bn = insertOp (BlockHeaderKey (h bn)) bn 263 | f (Just cf) bn = insertOpCF cf (BlockHeaderKey (h bn)) bn 264 | 265 | instance (MonadIO m) => BlockHeaders (ReaderT Chain m) where 266 | getBlockHeader bh = ReaderT $ chainGetBlock bh 267 | getBestBlockHeader = ReaderT chainGetBest 268 | addBlockHeader _ = undefined 269 | setBestBlockHeader _ = undefined 270 | addBlockHeaders _ = undefined 271 | 272 | withBlockHeaders :: (MonadChain m) => ReaderT ChainConfig m a -> m a 273 | withBlockHeaders f = do 274 | cfg <- asks (.config) 275 | runReaderT f cfg 276 | 277 | withChain :: 278 | (MonadUnliftIO m, MonadLoggerIO m) => 279 | ChainConfig -> 280 | (Chain -> m a) -> 281 | m a 282 | withChain cfg action = do 283 | (inbox, mailbox) <- newMailbox 284 | $(logDebugS) "Chain" "Starting chain actor" 285 | st <- 286 | newTVarIO 287 | ChainState 288 | { syncing = Nothing, 289 | beenInSync = False, 290 | peers = [] 291 | } 292 | let rd = ChainReader {config = cfg, state = st} 293 | ch = Chain {reader = rd, mailbox = mailbox} 294 | runReaderT initChainDB rd 295 | withAsync (main_loop ch rd inbox) $ \a -> 296 | link a >> action ch 297 | where 298 | main_loop ch rd inbox = 299 | withSyncLoop ch $ 300 | runReaderT (run inbox) rd 301 | run inbox = do 302 | withBlockHeaders getBestBlockHeader 303 | >>= chainEvent . ChainBestBlock 304 | forever $ do 305 | $(logDebugS) "Chain" "Awaiting event..." 306 | msg <- receive inbox 307 | chainMessage msg 308 | 309 | chainEvent :: (MonadChain m) => ChainEvent -> m () 310 | chainEvent e = do 311 | pub <- asks (.config.pub) 312 | case e of 313 | ChainBestBlock b -> 314 | $(logInfoS) "Chain" $ 315 | "Best block header at height: " 316 | <> cs (show b.height) 317 | ChainSynced b -> 318 | $(logInfoS) "Chain" $ 319 | "Headers in sync at height: " 320 | <> cs (show b.height) 321 | publish e pub 322 | 323 | processHeaders :: (MonadChain m) => Peer -> [BlockHeader] -> m () 324 | processHeaders p hs = do 325 | $(logDebugS) "Chain" $ 326 | "Processing " 327 | <> cs (show (length hs)) 328 | <> " headers from peer: " 329 | <> p.label 330 | net <- asks (.config.net) 331 | now <- liftIO getCurrentTime 332 | pbest <- withBlockHeaders getBestBlockHeader 333 | importHeaders net now hs >>= \case 334 | Left e -> do 335 | $(logErrorS) "Chain" $ 336 | "Could not connect headers from peer: " 337 | <> p.label 338 | e `killPeer` p 339 | Right done -> do 340 | setLastReceived 341 | best <- withBlockHeaders getBestBlockHeader 342 | when (pbest.header /= best.header) $ 343 | chainEvent (ChainBestBlock best) 344 | if done 345 | then do 346 | MSendHeaders `sendMessage` p 347 | finishPeer p 348 | syncNewPeer 349 | syncNotif 350 | else syncPeer p 351 | 352 | syncNewPeer :: (MonadChain m) => m () 353 | syncNewPeer = 354 | getSyncingPeer >>= \case 355 | Just _ -> return () 356 | Nothing -> 357 | nextPeer >>= \case 358 | Nothing -> return () 359 | Just p -> do 360 | $(logDebugS) "Chain" $ 361 | "Syncing against peer: " <> p.label 362 | syncPeer p 363 | 364 | syncNotif :: (MonadChain m) => m () 365 | syncNotif = 366 | notifySynced >>= \case 367 | False -> return () 368 | True -> 369 | withBlockHeaders getBestBlockHeader 370 | >>= chainEvent . ChainSynced 371 | 372 | syncPeer :: (MonadChain m) => Peer -> m () 373 | syncPeer p = do 374 | t <- liftIO getCurrentTime 375 | m <- 376 | chainSyncingPeer >>= \case 377 | Just 378 | ChainSync 379 | { peer = s, 380 | best = m 381 | } 382 | | p == s -> syncing_me t m 383 | | otherwise -> return Nothing 384 | Nothing -> syncing_new t 385 | forM_ m $ \g -> do 386 | $(logDebugS) "Chain" $ 387 | "Requesting headers from peer: " 388 | <> p.label 389 | MGetHeaders g `sendMessage` p 390 | where 391 | syncing_new t = 392 | setSyncingPeer p >>= \case 393 | False -> return Nothing 394 | True -> do 395 | $(logDebugS) "Chain" $ 396 | "Locked peer: " <> p.label 397 | h <- withBlockHeaders getBestBlockHeader 398 | Just <$> syncHeaders t h p 399 | syncing_me t m = do 400 | h <- case m of 401 | Nothing -> withBlockHeaders getBestBlockHeader 402 | Just h -> return h 403 | Just <$> syncHeaders t h p 404 | 405 | chainMessage :: (MonadChain m) => ChainMessage -> m () 406 | chainMessage (ChainHeaders p hs) = 407 | processHeaders p hs 408 | chainMessage (ChainPeerConnected p) = do 409 | $(logDebugS) "Chain" $ "Peer connected: " <> p.label 410 | addPeer p 411 | syncNewPeer 412 | chainMessage (ChainPeerDisconnected p) = do 413 | $(logDebugS) "Chain" $ "Peer disconnected: " <> p.label 414 | finishPeer p 415 | syncNewPeer 416 | chainMessage ChainPing = do 417 | $(logDebugS) "Chain" "Internal clock event" 418 | to <- asks (.config.timeout) 419 | now <- liftIO getCurrentTime 420 | chainSyncingPeer >>= \case 421 | Just ChainSync {peer = p, timestamp = t} 422 | | now `diffUTCTime` t > to -> do 423 | $(logErrorS) "Chain" $ 424 | "Syncing peer timed out: " <> p.label 425 | PeerTimeout `killPeer` p 426 | | otherwise -> return () 427 | Nothing -> syncNewPeer 428 | 429 | withSyncLoop :: 430 | (MonadUnliftIO m, MonadLoggerIO m) => 431 | Chain -> 432 | m a -> 433 | m a 434 | withSyncLoop ch f = 435 | withAsync go $ \a -> 436 | link a >> f 437 | where 438 | go = forever $ do 439 | delay <- 440 | liftIO $ 441 | randomRIO 442 | ( 2 * 1000 * 1000, 443 | 20 * 1000 * 1000 444 | ) 445 | threadDelay delay 446 | ChainPing `send` ch.mailbox 447 | 448 | -- | Version of the database. 449 | dataVersion :: Word32 450 | dataVersion = 1 451 | 452 | -- | Initialize header database. If version is different from current, the 453 | -- database is purged of conflicting elements first. 454 | initChainDB :: (MonadChain m) => m () 455 | initChainDB = do 456 | db <- asks (.config.db) 457 | mcf <- asks (.config.cf) 458 | net <- asks (.config.net) 459 | ver <- retrieveCommon db mcf ChainDataVersionKey 460 | when (ver /= Just dataVersion) $ purgeChainDB >>= writeBatch db 461 | case mcf of 462 | Nothing -> insert db ChainDataVersionKey dataVersion 463 | Just cf -> insertCF db cf ChainDataVersionKey dataVersion 464 | retrieveCommon db mcf BestBlockKey >>= \b -> 465 | when (isNothing (b :: Maybe BlockNode)) $ 466 | withBlockHeaders $ do 467 | addBlockHeader (genesisNode net) 468 | setBestBlockHeader (genesisNode net) 469 | 470 | -- | Purge database of elements having keys that may conflict with those used in 471 | -- this module. 472 | purgeChainDB :: (MonadChain m) => m [R.BatchOp] 473 | purgeChainDB = do 474 | db <- asks (.config.db) 475 | mcf <- asks (.config.cf) 476 | f db mcf $ \it -> do 477 | R.iterSeek it $ B.singleton 0x90 478 | recurse_delete it db mcf 479 | where 480 | f db Nothing = R.withIter db 481 | f db (Just cf) = R.withIterCF db cf 482 | recurse_delete it db mcf = 483 | R.iterKey it >>= \case 484 | Just k 485 | | B.head k == 0x90 || B.head k == 0x91 -> do 486 | case mcf of 487 | Nothing -> R.delete db k 488 | Just cf -> R.deleteCF db cf k 489 | R.iterNext it 490 | (R.Del k :) <$> recurse_delete it db mcf 491 | _ -> return [] 492 | 493 | -- | Import a bunch of continuous headers. Returns 'True' if the number of 494 | -- headers is 2000, which means that there are possibly more headers to sync 495 | -- from whatever peer delivered these. 496 | importHeaders :: 497 | (MonadChain m) => 498 | Network -> 499 | UTCTime -> 500 | [BlockHeader] -> 501 | m (Either PeerException Bool) 502 | importHeaders net now hs = 503 | runExceptT $ 504 | lift connect >>= \case 505 | Right _ -> do 506 | case hs of 507 | [] -> return () 508 | _ -> do 509 | bb <- lift get_last 510 | box <- asks (.state) 511 | atomically . modifyTVar box $ \s -> 512 | s {syncing = (\x -> x {best = bb}) <$> s.syncing} 513 | case length hs of 514 | 2000 -> return False 515 | _ -> return True 516 | Left _ -> throwError PeerSentBadHeaders 517 | where 518 | timestamp = floor (utcTimeToPOSIXSeconds now) 519 | connect = withBlockHeaders $ connectBlocks net timestamp hs 520 | get_last = withBlockHeaders . getBlockHeader . headerHash $ last hs 521 | 522 | -- | Check if best block header is in sync with the rest of the block chain by 523 | -- comparing the best block with the current time, verifying that there are no 524 | -- peers in the queue to be synced, and no peer is being synced at the moment. 525 | -- This function will only return 'True' once. It should be used to decide 526 | -- whether to notify other processes that the header chain has been synced. The 527 | -- state of the chain will be flipped to synced when this function returns 528 | -- 'True'. 529 | notifySynced :: (MonadChain m) => m Bool 530 | notifySynced = 531 | fmap isJust $ 532 | runMaybeT $ do 533 | bb <- lift $ withBlockHeaders getBestBlockHeader 534 | now <- liftIO getCurrentTime 535 | guard $ now `diffUTCTime` block_time bb > 7200 536 | st <- asks (.state) 537 | MaybeT . atomically . runMaybeT $ do 538 | s <- lift $ readTVar st 539 | guard $ isNothing s.syncing 540 | guard $ null s.peers 541 | guard $ not s.beenInSync 542 | lift $ writeTVar st s {beenInSync = True} 543 | return () 544 | where 545 | block_time = 546 | posixSecondsToUTCTime . fromIntegral . (.header.timestamp) 547 | 548 | -- | Get next peer to sync against from the queue. 549 | nextPeer :: (MonadChain m) => m (Maybe Peer) 550 | nextPeer = do 551 | ps <- (.peers) <$> (readTVarIO =<< asks (.state)) 552 | go ps 553 | where 554 | go [] = return Nothing 555 | go (p : ps) = 556 | setSyncingPeer p >>= \case 557 | True -> return (Just p) 558 | False -> go ps 559 | 560 | -- | Set a syncing peer and generate a 'GetHeaders' data structure with a block 561 | -- locator to send to that peer for syncing. 562 | syncHeaders :: 563 | (MonadChain m) => 564 | UTCTime -> 565 | BlockNode -> 566 | Peer -> 567 | m GetHeaders 568 | syncHeaders now bb p = do 569 | st <- asks (.state) 570 | atomically $ 571 | modifyTVar st $ \s -> 572 | s 573 | { syncing = 574 | Just 575 | ChainSync 576 | { peer = p, 577 | timestamp = now, 578 | best = Nothing 579 | }, 580 | peers = delete p s.peers 581 | } 582 | loc <- withBlockHeaders $ blockLocator bb 583 | return 584 | GetHeaders 585 | { version = myVersion, 586 | locator = loc, 587 | stop = z 588 | } 589 | where 590 | z = "0000000000000000000000000000000000000000000000000000000000000000" 591 | 592 | -- | Set the time of last received data to now if a syncing peer is active. 593 | setLastReceived :: (MonadChain m) => m () 594 | setLastReceived = do 595 | now <- liftIO getCurrentTime 596 | st <- asks (.state) 597 | let f ChainSync {..} = ChainSync {timestamp = now, ..} 598 | atomically . modifyTVar st $ \s -> 599 | s {syncing = f <$> s.syncing} 600 | 601 | -- | Add a new peer to the queue of peers to sync against. 602 | addPeer :: (MonadChain m) => Peer -> m () 603 | addPeer p = do 604 | st <- asks (.state) 605 | atomically . modifyTVar st $ \s -> s {peers = nub (p : s.peers)} 606 | 607 | -- | Get syncing peer if there is one. 608 | getSyncingPeer :: (MonadChain m) => m (Maybe Peer) 609 | getSyncingPeer = 610 | fmap (.peer) . (.syncing) 611 | <$> (readTVarIO =<< asks (.state)) 612 | 613 | setSyncingPeer :: (MonadChain m) => Peer -> m Bool 614 | setSyncingPeer p = 615 | setBusy p >>= \case 616 | False -> do 617 | $(logDebugS) "Chain" $ 618 | "Could not lock peer: " <> p.label 619 | return False 620 | True -> do 621 | $(logDebugS) "Chain" $ 622 | "Locked peer: " <> p.label 623 | set_it 624 | return True 625 | where 626 | set_it = do 627 | now <- liftIO getCurrentTime 628 | box <- asks (.state) 629 | atomically $ modifyTVar box $ \s -> 630 | s 631 | { syncing = 632 | Just 633 | ChainSync 634 | { peer = p, 635 | timestamp = now, 636 | best = Nothing 637 | } 638 | } 639 | 640 | -- | Remove a peer from the queue of peers to sync and unset the syncing peer if 641 | -- it is set to the provided peer. 642 | finishPeer :: (MonadChain m) => Peer -> m () 643 | finishPeer p = 644 | asks (.state) >>= remove_peer >>= \case 645 | False -> 646 | $(logDebugS) "Chain" $ 647 | "Removed peer from queue: " <> p.label 648 | True -> do 649 | $(logDebugS) "Chain" $ 650 | "Releasing syncing peer: " <> p.label 651 | setFree p 652 | where 653 | remove_peer st = 654 | atomically $ 655 | readTVar st >>= \s -> case s.syncing of 656 | Just ChainSync {peer = p'} 657 | | p == p' -> do 658 | unset_syncing st 659 | return True 660 | _ -> do 661 | remove_from_queue st 662 | return False 663 | unset_syncing st = 664 | modifyTVar st $ \x -> 665 | x {syncing = Nothing} 666 | remove_from_queue st = 667 | modifyTVar st $ \x -> 668 | x {peers = delete p x.peers} 669 | 670 | -- | Return syncing peer data. 671 | chainSyncingPeer :: (MonadChain m) => m (Maybe ChainSync) 672 | chainSyncingPeer = 673 | (.syncing) <$> (readTVarIO =<< asks (.state)) 674 | 675 | -- | Get a block header from 'Chain' process. 676 | chainGetBlock :: 677 | (MonadIO m) => 678 | BlockHash -> 679 | Chain -> 680 | m (Maybe BlockNode) 681 | chainGetBlock bh ch = 682 | runReaderT (getBlockHeader bh) (ch.reader.config) 683 | 684 | -- | Get best block header from chain process. 685 | chainGetBest :: (MonadIO m) => Chain -> m BlockNode 686 | chainGetBest ch = 687 | runReaderT getBestBlockHeader ch.reader.config 688 | 689 | -- | Get ancestor of 'BlockNode' at 'BlockHeight' from chain process. 690 | chainGetAncestor :: 691 | (MonadIO m) => 692 | BlockHeight -> 693 | BlockNode -> 694 | Chain -> 695 | m (Maybe BlockNode) 696 | chainGetAncestor h bn ch = 697 | runReaderT (getAncestor h bn) ch.reader.config 698 | 699 | -- | Get parents of 'BlockNode' starting at 'BlockHeight' from chain process. 700 | chainGetParents :: 701 | (MonadIO m) => 702 | BlockHeight -> 703 | BlockNode -> 704 | Chain -> 705 | m [BlockNode] 706 | chainGetParents height top ch = 707 | go [] top 708 | where 709 | go acc b 710 | | height >= b.height = return acc 711 | | otherwise = do 712 | m <- chainGetBlock b.header.prev ch 713 | case m of 714 | Nothing -> return acc 715 | Just p -> go (p : acc) p 716 | 717 | -- | Get last common block from chain process. 718 | chainGetSplitBlock :: 719 | (MonadIO m) => 720 | BlockNode -> 721 | BlockNode -> 722 | Chain -> 723 | m BlockNode 724 | chainGetSplitBlock l r ch = 725 | runReaderT (splitPoint l r) ch.reader.config 726 | 727 | -- | Notify chain that a new peer is connected. 728 | chainPeerConnected :: 729 | (MonadIO m) => 730 | Peer -> 731 | Chain -> 732 | m () 733 | chainPeerConnected p ch = 734 | ChainPeerConnected p `send` ch.mailbox 735 | 736 | -- | Notify chain that a peer has disconnected. 737 | chainPeerDisconnected :: 738 | (MonadIO m) => 739 | Peer -> 740 | Chain -> 741 | m () 742 | chainPeerDisconnected p ch = 743 | ChainPeerDisconnected p `send` ch.mailbox 744 | 745 | -- | Is given 'BlockHash' in the main chain? 746 | chainBlockMain :: 747 | (MonadIO m) => 748 | BlockHash -> 749 | Chain -> 750 | m Bool 751 | chainBlockMain bh ch = 752 | chainGetBest ch >>= \bb -> 753 | chainGetBlock bh ch >>= \case 754 | Nothing -> 755 | return False 756 | bm@(Just bn) -> 757 | (== bm) <$> chainGetAncestor bn.height bb ch 758 | 759 | -- | Is chain in sync with network? 760 | chainIsSynced :: (MonadIO m) => Chain -> m Bool 761 | chainIsSynced ch = 762 | (.beenInSync) <$> readTVarIO (ch.reader.state) 763 | 764 | -- | Peer sends a bunch of headers to the chain process. 765 | chainHeaders :: 766 | (MonadIO m) => 767 | Peer -> 768 | [BlockHeader] -> 769 | Chain -> 770 | m () 771 | chainHeaders p hs ch = 772 | ChainHeaders p hs `send` ch.mailbox 773 | -------------------------------------------------------------------------------- /src/Haskoin/Node/Peer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE DuplicateRecordFields #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE ImportQualifiedPost #-} 5 | {-# LANGUAGE LambdaCase #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE NamedFieldPuns #-} 8 | {-# LANGUAGE OverloadedRecordDot #-} 9 | {-# LANGUAGE OverloadedStrings #-} 10 | {-# LANGUAGE RecordWildCards #-} 11 | {-# LANGUAGE TemplateHaskell #-} 12 | {-# LANGUAGE TypeFamilies #-} 13 | {-# LANGUAGE NoFieldSelectors #-} 14 | 15 | module Haskoin.Node.Peer 16 | ( PeerConfig (..), 17 | PeerEvent (..), 18 | Conduits (..), 19 | PeerException (..), 20 | WithConnection, 21 | Peer (..), 22 | peer, 23 | wrapPeer, 24 | sendMessage, 25 | killPeer, 26 | getBlocks, 27 | getTxs, 28 | getData, 29 | pingPeer, 30 | getBusy, 31 | setBusy, 32 | setFree, 33 | ) 34 | where 35 | 36 | import Conduit 37 | ( ConduitT, 38 | Void, 39 | awaitForever, 40 | foldC, 41 | mapM_C, 42 | runConduit, 43 | takeCE, 44 | transPipe, 45 | yield, 46 | (.|), 47 | ) 48 | import Control.Monad (forever, join, unless, when) 49 | import Control.Monad.Logger (MonadLoggerIO, logDebugS, logErrorS, logInfoS) 50 | import Control.Monad.Trans.Maybe (MaybeT (MaybeT), runMaybeT) 51 | import Data.Bool (bool) 52 | import Data.ByteString (ByteString) 53 | import Data.ByteString qualified as B 54 | import Data.Function (on) 55 | import Data.List (union) 56 | import Data.Maybe (isJust) 57 | import Data.Serialize (decode, runGet, runPut) 58 | import Data.String.Conversions (cs) 59 | import Data.Text (Text) 60 | import Data.Word (Word32) 61 | import Haskoin 62 | ( Block (..), 63 | BlockHash (..), 64 | GetData (..), 65 | InvType (..), 66 | InvVector (..), 67 | Message (..), 68 | MessageCommand (..), 69 | MessageHeader (..), 70 | Network (..), 71 | NotFound (..), 72 | Ping (..), 73 | Pong (..), 74 | Tx, 75 | TxHash (..), 76 | commandToString, 77 | encodeHex, 78 | getMessage, 79 | headerHash, 80 | putMessage, 81 | txHash, 82 | ) 83 | import NQE 84 | ( Inbox, 85 | Mailbox, 86 | Publisher, 87 | inboxToMailbox, 88 | publish, 89 | receive, 90 | receiveMatchS, 91 | send, 92 | withSubscription, 93 | ) 94 | import System.Random (randomIO) 95 | import UnliftIO 96 | ( Exception, 97 | MonadIO, 98 | MonadUnliftIO, 99 | TVar, 100 | atomically, 101 | liftIO, 102 | link, 103 | readTVar, 104 | readTVarIO, 105 | throwIO, 106 | timeout, 107 | withAsync, 108 | withRunInIO, 109 | writeTVar, 110 | ) 111 | 112 | data Conduits = Conduits 113 | { inboundConduit :: ConduitT () ByteString IO (), 114 | outboundConduit :: ConduitT ByteString Void IO () 115 | } 116 | 117 | type WithConnection = (Conduits -> IO ()) -> IO () 118 | 119 | data PeerConfig = PeerConfig 120 | { pub :: !(Publisher PeerEvent), 121 | net :: !Network, 122 | label :: !Text, 123 | connect :: !WithConnection 124 | } 125 | 126 | data PeerEvent 127 | = PeerConnected !Peer 128 | | PeerDisconnected !Peer 129 | | PeerMessage !Peer !Message 130 | deriving (Eq) 131 | 132 | data PeerException 133 | = PeerMisbehaving !String 134 | | DuplicateVersion 135 | | DecodeHeaderError 136 | | CannotDecodePayload !MessageCommand 137 | | PeerIsMyself 138 | | PayloadTooLarge !Word32 139 | | PeerAddressInvalid 140 | | PeerSentBadHeaders 141 | | NotNetworkPeer 142 | | PeerNoSegWit 143 | | PeerTimeout 144 | | UnknownPeer 145 | | PeerTooOld 146 | | EmptyHeader 147 | deriving (Eq) 148 | 149 | instance Show PeerException where 150 | show (PeerMisbehaving s) = "Peer misbehaving: " <> s 151 | show DuplicateVersion = "Duplicate version" 152 | show DecodeHeaderError = "Error decoding header" 153 | show (CannotDecodePayload c) = 154 | "Cannot decode payload: " 155 | <> cs (commandToString c) 156 | show PeerIsMyself = "Peer is myself" 157 | show (PayloadTooLarge s) = "Payload too large: " <> show s 158 | show PeerAddressInvalid = "Peer address invalid" 159 | show PeerSentBadHeaders = "Peer sent bad headers" 160 | show NotNetworkPeer = "Not network peer" 161 | show PeerNoSegWit = "Segwit not supported by peer" 162 | show PeerTimeout = "Peer timed out" 163 | show UnknownPeer = "Unknown peer" 164 | show PeerTooOld = "Peer too old" 165 | show EmptyHeader = "Empty header" 166 | 167 | instance Exception PeerException 168 | 169 | -- | Mailbox for a peer. 170 | data Peer = Peer 171 | { mailbox :: !(Mailbox PeerMessage), 172 | pub :: !(Publisher PeerEvent), 173 | label :: !Text, 174 | busy :: !(TVar Bool) 175 | } 176 | 177 | instance Eq Peer where 178 | (==) = (==) `on` (.mailbox) 179 | 180 | instance Show Peer where 181 | show = cs . (.label) 182 | 183 | -- | Incoming messages that a peer accepts. 184 | data PeerMessage 185 | = KillPeer !PeerException 186 | | SendMessage !Message 187 | 188 | wrapPeer :: 189 | (MonadIO m) => 190 | PeerConfig -> 191 | TVar Bool -> 192 | Mailbox PeerMessage -> 193 | m Peer 194 | wrapPeer cfg busy mbox = 195 | return 196 | Peer 197 | { mailbox = mbox, 198 | pub = cfg.pub, 199 | label = cfg.label, 200 | busy = busy 201 | } 202 | 203 | -- | Run peer process in current thread. 204 | peer :: 205 | (MonadUnliftIO m, MonadLoggerIO m) => 206 | PeerConfig -> 207 | TVar Bool -> 208 | Inbox PeerMessage -> 209 | m () 210 | peer cfg@PeerConfig {..} busy inbox = do 211 | p <- wrapPeer cfg busy (inboxToMailbox inbox) 212 | withRunInIO $ \restore -> do 213 | connect (restore . peer_session p) 214 | where 215 | go = forever $ do 216 | $(logDebugS) "Peer" $ label <> " awaiting event..." 217 | msg <- receive inbox 218 | dispatchMessage cfg msg 219 | peer_session p ad = do 220 | let ins = transPipe liftIO ad.inboundConduit 221 | ons = transPipe liftIO ad.outboundConduit 222 | src = 223 | runConduit $ 224 | ins 225 | .| inPeerConduit net cfg label 226 | .| mapM_C (send_msg p) 227 | snk = outPeerConduit net .| ons 228 | withAsync src $ \as -> do 229 | link as 230 | runConduit (go .| snk) 231 | send_msg p msg = publish (PeerMessage p msg) pub 232 | 233 | -- | Internal function to dispatch peer messages. 234 | dispatchMessage :: 235 | (MonadLoggerIO m) => 236 | PeerConfig -> 237 | PeerMessage -> 238 | ConduitT i Message m () 239 | dispatchMessage PeerConfig {label} (SendMessage msg) = do 240 | $(logDebugS) "Peer" $ label <> " sending: " <> cs (show msg) 241 | yield msg 242 | dispatchMessage PeerConfig {label} (KillPeer e) = do 243 | $(logInfoS) "Peer" $ label <> " killing with error: " <> cs (show e) 244 | throwIO e 245 | 246 | -- | Internal conduit to parse messages coming from peer. 247 | inPeerConduit :: 248 | (MonadLoggerIO m) => 249 | Network -> 250 | PeerConfig -> 251 | Text -> 252 | ConduitT ByteString Message m () 253 | inPeerConduit net PeerConfig {label} a = 254 | forever $ do 255 | $(logDebugS) "Peer" $ label <> " awaiting network message..." 256 | x <- takeCE 24 .| foldC 257 | when (B.null x) $ do 258 | $(logErrorS) "Peer" $ label <> " empty header" 259 | throwIO EmptyHeader 260 | case decode x of 261 | Left e -> do 262 | $(logErrorS) "Peer" $ label <> " error decoding header" 263 | throwIO DecodeHeaderError 264 | Right (MessageHeader _ cmd len _) -> do 265 | $(logDebugS) "Peer" $ label <> " received: " <> cs (show cmd) 266 | when (len > 32 * 2 ^ (20 :: Int)) $ do 267 | $(logErrorS) "Peer" $ label <> " payload too large: " <> cs (show len) 268 | throwIO $ PayloadTooLarge len 269 | y <- takeCE (fromIntegral len) .| foldC 270 | case runGet (getMessage net) $ x `B.append` y of 271 | Left e -> do 272 | $(logErrorS) "Peer" $ 273 | label 274 | <> " could not decode payload for cmd: " 275 | <> cs (show cmd) 276 | throwIO (CannotDecodePayload cmd) 277 | Right msg -> do 278 | $(logDebugS) "Peer" $ label <> " forwarding: " <> cs (show msg) 279 | yield msg 280 | 281 | -- | Outgoing peer conduit to serialize and send messages. 282 | outPeerConduit :: (Monad m) => Network -> ConduitT Message ByteString m () 283 | outPeerConduit net = awaitForever $ yield . runPut . putMessage net 284 | 285 | -- | Kill a peer with the provided exception. 286 | killPeer :: (MonadIO m) => PeerException -> Peer -> m () 287 | killPeer e p = KillPeer e `send` p.mailbox 288 | 289 | -- | Send a network message to peer. 290 | sendMessage :: (MonadIO m) => Message -> Peer -> m () 291 | sendMessage msg p = SendMessage msg `send` p.mailbox 292 | 293 | getBusy :: (MonadIO m) => Peer -> m Bool 294 | getBusy p = readTVarIO p.busy 295 | 296 | setBusy :: (MonadIO m) => Peer -> m Bool 297 | setBusy p = 298 | atomically $ do 299 | b <- readTVar p.busy 300 | unless b $ writeTVar p.busy True 301 | return $ not b 302 | 303 | setFree :: (MonadIO m) => Peer -> m () 304 | setFree p = atomically $ writeTVar p.busy False 305 | 306 | -- | Request full blocks from peer. Will return 'Nothing' if the list of blocks 307 | -- returned by the peer is incomplete, comes out of order, or a timeout is 308 | -- reached. 309 | getBlocks :: 310 | (MonadUnliftIO m) => 311 | Network -> 312 | Int -> 313 | Peer -> 314 | [BlockHash] -> 315 | m (Maybe [Block]) 316 | getBlocks net time p bhs = 317 | runMaybeT $ mapM f =<< MaybeT (getData time p (GetData ivs)) 318 | where 319 | f (Right b) = return b 320 | f (Left _) = MaybeT $ return Nothing 321 | c 322 | | net.segWit = InvWitnessBlock 323 | | otherwise = InvBlock 324 | ivs = map (InvVector c . (.get)) bhs 325 | 326 | -- | Request transactions from peer. Will return 'Nothing' if the list of 327 | -- transactions returned by the peer is incomplete, comes out of order, or a 328 | -- timeout is reached. 329 | getTxs :: 330 | (MonadUnliftIO m) => 331 | Network -> 332 | Int -> 333 | Peer -> 334 | [TxHash] -> 335 | m (Maybe [Tx]) 336 | getTxs net time p ths = 337 | runMaybeT $ mapM f =<< MaybeT (getData time p (GetData ivs)) 338 | where 339 | f (Right _) = MaybeT $ return Nothing 340 | f (Left t) = return t 341 | c 342 | | net.segWit = InvWitnessTx 343 | | otherwise = InvTx 344 | ivs = map (InvVector c . (.get)) ths 345 | 346 | -- | Request transactions and/or blocks from peer. Return 'Nothing' if any 347 | -- single inventory fails to be retrieved, if they come out of order, or if 348 | -- timeout is reached. 349 | getData :: 350 | (MonadUnliftIO m) => Int -> Peer -> GetData -> m (Maybe [Either Tx Block]) 351 | getData seconds p gd@(GetData ivs) = 352 | withSubscription p.pub $ \inb -> do 353 | r <- liftIO randomIO 354 | MGetData gd `sendMessage` p 355 | MPing (Ping r) `sendMessage` p 356 | fmap join 357 | . timeout (seconds * 1000 * 1000) 358 | . runMaybeT 359 | $ get_thing inb r [] ivs 360 | where 361 | get_thing _inb _r acc [] = 362 | return $ reverse acc 363 | get_thing inb r acc hss@(InvVector t h : hs) = 364 | filterReceive p inb >>= \case 365 | MTx tx 366 | | is_tx t && (txHash tx).get == h -> 367 | get_thing inb r (Left tx : acc) hs 368 | MBlock b@(Block bh _) 369 | | is_block t && (headerHash bh).get == h -> 370 | get_thing inb r (Right b : acc) hs 371 | MNotFound (NotFound nvs) 372 | | not (null (nvs `union` hs)) -> 373 | MaybeT $ return Nothing 374 | MPong (Pong r') 375 | | r == r' -> 376 | MaybeT $ return Nothing 377 | _ 378 | | null acc -> 379 | get_thing inb r acc hss 380 | | otherwise -> 381 | MaybeT $ return Nothing 382 | is_tx InvWitnessTx = True 383 | is_tx InvTx = True 384 | is_tx _ = False 385 | is_block InvWitnessBlock = True 386 | is_block InvBlock = True 387 | is_block _ = False 388 | 389 | -- | Ping a peer and await response. Return 'False' if response not received 390 | -- before timeout. 391 | pingPeer :: (MonadUnliftIO m) => Int -> Peer -> m Bool 392 | pingPeer time p = 393 | fmap isJust . withSubscription p.pub $ \sub -> do 394 | r <- liftIO randomIO 395 | MPing (Ping r) `sendMessage` p 396 | receiveMatchS time sub $ \case 397 | PeerMessage p' (MPong (Pong r')) 398 | | p == p' && r == r' -> Just () 399 | _ -> Nothing 400 | 401 | filterReceive :: (MonadIO m) => Peer -> Inbox PeerEvent -> m Message 402 | filterReceive p inb = 403 | receive inb >>= \case 404 | PeerMessage p' msg | p == p' -> return msg 405 | _ -> filterReceive p inb 406 | -------------------------------------------------------------------------------- /src/Haskoin/Node/PeerMgr.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE DuplicateRecordFields #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE LambdaCase #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE MultiWayIf #-} 8 | {-# LANGUAGE OverloadedRecordDot #-} 9 | {-# LANGUAGE OverloadedStrings #-} 10 | {-# LANGUAGE TemplateHaskell #-} 11 | {-# LANGUAGE TupleSections #-} 12 | {-# LANGUAGE NoFieldSelectors #-} 13 | 14 | module Haskoin.Node.PeerMgr 15 | ( PeerMgrConfig (..), 16 | PeerEvent (..), 17 | OnlinePeer (..), 18 | PeerMgr, 19 | withPeerMgr, 20 | peerMgrBest, 21 | peerMgrVersion, 22 | peerMgrPing, 23 | peerMgrPong, 24 | peerMgrAddrs, 25 | peerMgrVerAck, 26 | getPeers, 27 | getOnlinePeer, 28 | ticklePeer, 29 | buildVersion, 30 | myVersion, 31 | toSockAddr, 32 | toHostService, 33 | ) 34 | where 35 | 36 | import Control.Applicative ((<|>)) 37 | import Control.Arrow 38 | import Control.Monad 39 | ( forM_, 40 | forever, 41 | guard, 42 | unless, 43 | void, 44 | when, 45 | (<=<), 46 | ) 47 | import Control.Monad.Except 48 | ( ExceptT (..), 49 | runExceptT, 50 | throwError, 51 | ) 52 | import Control.Monad.Logger 53 | ( MonadLogger, 54 | MonadLoggerIO, 55 | logDebugS, 56 | logErrorS, 57 | logInfoS, 58 | logWarnS, 59 | ) 60 | import Control.Monad.Reader 61 | ( MonadReader, 62 | ReaderT (ReaderT), 63 | ask, 64 | asks, 65 | runReaderT, 66 | ) 67 | import Control.Monad.Trans (lift) 68 | import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) 69 | import Data.Bits ((.&.)) 70 | import Data.Function (on) 71 | import Data.List (dropWhileEnd, elemIndex, find, nub, sort) 72 | import Data.Maybe (fromMaybe, isJust, isNothing) 73 | import Data.Set (Set) 74 | import qualified Data.Set as Set 75 | import Data.String.Conversions (cs) 76 | import Data.Time.Clock 77 | ( NominalDiffTime, 78 | UTCTime, 79 | addUTCTime, 80 | diffUTCTime, 81 | getCurrentTime, 82 | ) 83 | import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) 84 | import Data.Word (Word32, Word64) 85 | import Haskoin 86 | ( BlockHeight, 87 | Message (..), 88 | Network (..), 89 | NetworkAddress (..), 90 | Ping (..), 91 | Pong (..), 92 | VarString (..), 93 | Version (..), 94 | hostToSockAddr, 95 | nodeNetwork, 96 | sockToHostAddress, 97 | ) 98 | import Haskoin.Node.Peer 99 | import NQE 100 | ( Child, 101 | Inbox, 102 | Mailbox, 103 | Publisher, 104 | Strategy (..), 105 | Supervisor, 106 | addChild, 107 | inboxToMailbox, 108 | newInbox, 109 | newMailbox, 110 | publish, 111 | receive, 112 | receiveMatch, 113 | send, 114 | sendSTM, 115 | withSupervisor, 116 | ) 117 | import Network.Socket 118 | ( AddrInfo (..), 119 | AddrInfoFlag (..), 120 | Family (..), 121 | SockAddr (..), 122 | SocketType (..), 123 | defaultHints, 124 | getAddrInfo, 125 | ) 126 | import System.Random (randomIO, randomRIO) 127 | import UnliftIO 128 | ( Async, 129 | MonadIO, 130 | MonadUnliftIO, 131 | STM, 132 | SomeException, 133 | TVar, 134 | atomically, 135 | catch, 136 | liftIO, 137 | link, 138 | modifyTVar, 139 | newTVarIO, 140 | readTVar, 141 | readTVarIO, 142 | withAsync, 143 | withRunInIO, 144 | writeTVar, 145 | ) 146 | import UnliftIO.Concurrent (threadDelay) 147 | 148 | type MonadManager m = (MonadIO m, MonadReader PeerMgr m) 149 | 150 | data PeerMgrConfig = PeerMgrConfig 151 | { maxPeers :: !Int, 152 | peers :: ![String], 153 | discover :: !Bool, 154 | address :: !NetworkAddress, 155 | net :: !Network, 156 | pub :: !(Publisher PeerEvent), 157 | timeout :: !NominalDiffTime, 158 | maxPeerLife :: !NominalDiffTime, 159 | connect :: !(SockAddr -> WithConnection) 160 | } 161 | 162 | data PeerMgr = PeerMgr 163 | { config :: !PeerMgrConfig, 164 | supervisor :: !Supervisor, 165 | mailbox :: !(Mailbox PeerMgrMessage), 166 | best :: !(TVar BlockHeight), 167 | addresses :: !(TVar (Set SockAddr)), 168 | peers :: !(TVar [OnlinePeer]) 169 | } 170 | 171 | data PeerMgrMessage 172 | = Connect !SockAddr 173 | | CheckPeer !Peer 174 | | PeerDied !Child !(Maybe SomeException) 175 | | ManagerBest !BlockHeight 176 | | PeerVerAck !Peer 177 | | PeerVersion !Peer !Version 178 | | PeerPing !Peer !Word64 179 | | PeerPong !Peer !Word64 180 | | PeerAddrs !Peer ![NetworkAddress] 181 | 182 | -- | Data structure representing an online peer. 183 | data OnlinePeer = OnlinePeer 184 | { address :: !SockAddr, 185 | verack :: !Bool, 186 | online :: !Bool, 187 | version :: !(Maybe Version), 188 | async :: !(Async ()), 189 | mailbox :: !Peer, 190 | nonce :: !Word64, 191 | ping :: !(Maybe (UTCTime, Word64)), 192 | pings :: ![NominalDiffTime], 193 | connected :: !UTCTime, 194 | tickled :: !UTCTime 195 | } 196 | 197 | instance Eq OnlinePeer where 198 | (==) = (==) `on` f 199 | where 200 | f OnlinePeer {mailbox = p} = p 201 | 202 | instance Ord OnlinePeer where 203 | compare = compare `on` f 204 | where 205 | f OnlinePeer {pings = pings} = fromMaybe 60 (median pings) 206 | 207 | withPeerMgr :: 208 | (MonadUnliftIO m, MonadLoggerIO m) => 209 | PeerMgrConfig -> 210 | (PeerMgr -> m a) -> 211 | m a 212 | withPeerMgr cfg action = do 213 | inbox <- newInbox 214 | let mgr = inboxToMailbox inbox 215 | withSupervisor (Notify (death mgr)) $ \sup -> do 216 | bb <- newTVarIO 0 217 | kp <- newTVarIO Set.empty 218 | ob <- newTVarIO [] 219 | runReaderT 220 | (go inbox) 221 | PeerMgr 222 | { config = cfg, 223 | supervisor = sup, 224 | mailbox = mgr, 225 | best = bb, 226 | addresses = kp, 227 | peers = ob 228 | } 229 | where 230 | death mgr (a, ex) = PeerDied a ex `sendSTM` mgr 231 | go inbox = 232 | withAsync (peerManager inbox) $ \a -> 233 | withConnectLoop $ 234 | link a >> ReaderT action 235 | 236 | peerManager :: 237 | ( MonadUnliftIO m, 238 | MonadManager m, 239 | MonadLoggerIO m 240 | ) => 241 | Inbox PeerMgrMessage -> 242 | m () 243 | peerManager inb = do 244 | $(logDebugS) "PeerMgr" "Awaiting best block" 245 | putBestBlock <=< receiveMatch inb $ \case 246 | ManagerBest b -> Just b 247 | _ -> Nothing 248 | $(logDebugS) "PeerMgr" "Starting peer manager actor" 249 | forever $ do 250 | $(logDebugS) "PeerMgr" "Awaiting event..." 251 | dispatch =<< receive inb 252 | 253 | putBestBlock :: (MonadManager m) => BlockHeight -> m () 254 | putBestBlock bb = do 255 | b <- asks (.best) 256 | atomically $ writeTVar b bb 257 | 258 | getBestBlock :: (MonadManager m) => m BlockHeight 259 | getBestBlock = 260 | asks (.best) >>= readTVarIO 261 | 262 | getNetwork :: (MonadManager m) => m Network 263 | getNetwork = 264 | asks (.config.net) 265 | 266 | loadPeers :: (MonadUnliftIO m, MonadManager m) => m () 267 | loadPeers = do 268 | loadStaticPeers 269 | loadNetSeeds 270 | 271 | loadStaticPeers :: (MonadUnliftIO m, MonadManager m) => m () 272 | loadStaticPeers = do 273 | net <- asks (.config.net) 274 | xs <- asks (.config.peers) 275 | mapM_ newPeer . concat =<< mapM (toSockAddr net) xs 276 | 277 | loadNetSeeds :: (MonadUnliftIO m, MonadManager m) => m () 278 | loadNetSeeds = 279 | asks (.config.discover) >>= \discover -> 280 | when discover $ do 281 | net <- getNetwork 282 | ss <- concat <$> mapM (toSockAddr net) net.seeds 283 | mapM_ newPeer ss 284 | 285 | logConnectedPeers :: (MonadManager m, MonadLoggerIO m) => m () 286 | logConnectedPeers = do 287 | m <- asks (.config.maxPeers) 288 | l <- length <$> getConnectedPeers 289 | $(logInfoS) "PeerMgr" $ 290 | "Peers connected: " <> cs (show l) <> "/" <> cs (show m) 291 | 292 | getOnlinePeers :: (MonadManager m) => m [OnlinePeer] 293 | getOnlinePeers = 294 | asks (.peers) >>= readTVarIO 295 | 296 | getConnectedPeers :: (MonadManager m) => m [OnlinePeer] 297 | getConnectedPeers = 298 | filter (.online) <$> getOnlinePeers 299 | 300 | managerEvent :: (MonadManager m) => PeerEvent -> m () 301 | managerEvent e = 302 | publish e =<< asks (.config.pub) 303 | 304 | dispatch :: 305 | ( MonadUnliftIO m, 306 | MonadManager m, 307 | MonadLoggerIO m 308 | ) => 309 | PeerMgrMessage -> 310 | m () 311 | dispatch (PeerVersion p v) = do 312 | $(logDebugS) "PeerMgr" $ 313 | "Received peer " <> p.label <> " version: " <> cs (show v) 314 | b <- asks (.peers) 315 | e <- runExceptT $ do 316 | o <- ExceptT . atomically $ setPeerVersion b p v 317 | when o.online $ announcePeer p 318 | case e of 319 | Right () -> do 320 | $(logDebugS) "PeerMgr" $ 321 | "Sending version ack to peer: " <> p.label 322 | MVerAck `sendMessage` p 323 | Left x -> do 324 | $(logErrorS) "PeerMgr" $ 325 | "Version rejected for peer " 326 | <> p.label 327 | <> ": " 328 | <> cs (show x) 329 | killPeer x p 330 | dispatch (PeerVerAck p) = do 331 | b <- asks (.peers) 332 | atomically (setPeerVerAck b p) >>= \case 333 | Just o -> do 334 | $(logDebugS) "PeerMgr" $ 335 | "Received version ack from peer: " 336 | <> p.label 337 | when o.online $ 338 | announcePeer p 339 | Nothing -> do 340 | $(logErrorS) "PeerMgr" $ 341 | "Received verack from unknown peer: " 342 | <> p.label 343 | killPeer UnknownPeer p 344 | dispatch (PeerAddrs p nas) = do 345 | $(logDebugS) "PeerMgr" $ 346 | "Received addresses from peer " <> p.label 347 | discover <- asks (.config.discover) 348 | when discover $ do 349 | let sas = map (hostToSockAddr . (.address)) nas 350 | forM_ (zip [(1 :: Int) ..] sas) $ \(i, a) -> do 351 | $(logDebugS) "PeerMgr" $ 352 | "Got peer address " 353 | <> cs (show i) 354 | <> "/" 355 | <> cs (show (length sas)) 356 | <> ": " 357 | <> cs (show a) 358 | <> " from peer " 359 | <> p.label 360 | newPeer a 361 | dispatch (PeerPong p n) = do 362 | b <- asks (.peers) 363 | $(logDebugS) "PeerMgr" $ 364 | "Received pong " 365 | <> cs (show n) 366 | <> " from: " 367 | <> p.label 368 | now <- liftIO getCurrentTime 369 | atomically (gotPong b n now p) 370 | dispatch (PeerPing p n) = do 371 | $(logDebugS) "PeerMgr" $ 372 | "Responding to ping " 373 | <> cs (show n) 374 | <> " from: " 375 | <> p.label 376 | MPong (Pong n) `sendMessage` p 377 | dispatch (ManagerBest h) = do 378 | $(logDebugS) "PeerMgr" $ 379 | "Setting best block to " <> cs (show h) 380 | putBestBlock h 381 | dispatch (Connect sa) = do 382 | connectPeer sa 383 | dispatch (PeerDied a e) = do 384 | processPeerOffline a e 385 | dispatch (CheckPeer p) = do 386 | $(logDebugS) "PeerMgr" $ 387 | "Housekeeping for peer " <> p.label 388 | checkPeer p 389 | 390 | ticklePeer :: ( MonadLoggerIO m) => PeerMgr -> Peer -> m () 391 | ticklePeer m p = do 392 | $(logDebugS) "PeerMgr" $ "Tickle peer " <> p.label 393 | t <- liftIO getCurrentTime 394 | atomically $ modifyPeer m.peers p $ \o -> o {tickled = t} 395 | 396 | checkPeer :: (MonadManager m, MonadLoggerIO m) => Peer -> m () 397 | checkPeer p = do 398 | busy <- getBusy p 399 | b <- asks (.peers) 400 | mp <- asks (.peers) >>= atomically . flip findPeer p 401 | case mp of 402 | Nothing -> return () 403 | Just o -> do 404 | now <- liftIO getCurrentTime 405 | maxLife <- asks (.config.maxPeerLife) 406 | let expired = maxLife `addUTCTime` o.connected 407 | timeout <- asks (.config.timeout) 408 | let deadline = timeout `addUTCTime` o.tickled 409 | if 410 | | now > expired -> do 411 | $(logErrorS) "PeerMgr" $ 412 | "Disconnecting old peer " 413 | <> p.label 414 | <> " online since " 415 | <> cs (show o.connected) 416 | killPeer PeerTooOld p 417 | | now > deadline -> do 418 | $(logWarnS) "PeerMgr" $ "Peer timeout: " <> p.label 419 | killPeer PeerTimeout p 420 | | isNothing o.ping -> 421 | sendPing p 422 | | otherwise -> return () 423 | 424 | sendPing :: (MonadManager m, MonadLoggerIO m) => Peer -> m () 425 | sendPing p = do 426 | b <- asks (.peers) 427 | atomically (findPeer b p) >>= \case 428 | Nothing -> 429 | $(logWarnS) "PeerMgr" $ 430 | "Will not ping unknown peer: " <> p.label 431 | Just o 432 | | o.online -> do 433 | n <- liftIO randomIO 434 | now <- liftIO getCurrentTime 435 | atomically (setPeerPing b n now p) 436 | $(logDebugS) "PeerMgr" $ 437 | "Sending ping " 438 | <> cs (show n) 439 | <> " to: " 440 | <> p.label 441 | MPing (Ping n) `sendMessage` p 442 | | otherwise -> return () 443 | 444 | processPeerOffline :: 445 | (MonadManager m, MonadLoggerIO m) => 446 | Child -> 447 | Maybe SomeException -> 448 | m () 449 | processPeerOffline a e = do 450 | b <- asks (.peers) 451 | atomically (findPeerAsync b a) >>= \case 452 | Nothing -> log_unknown e 453 | Just o -> do 454 | let p = o.mailbox 455 | if o.online 456 | then do 457 | log_disconnected p e 458 | managerEvent $ PeerDisconnected p 459 | else log_not_connect p e 460 | atomically $ removePeer b p 461 | logConnectedPeers 462 | where 463 | log_unknown Nothing = 464 | $(logErrorS) 465 | "PeerMgr" 466 | "Disconnected unknown peer" 467 | log_unknown (Just x) = 468 | $(logErrorS) "PeerMgr" $ 469 | "Unknown peer died: " <> cs (show x) 470 | log_disconnected p Nothing = 471 | $(logWarnS) "PeerMgr" $ 472 | "Disconnected peer: " <> p.label 473 | log_disconnected p (Just x) = 474 | $(logErrorS) "PeerMgr" $ 475 | "Peer " <> p.label <> " died: " <> cs (show x) 476 | log_not_connect p Nothing = 477 | $(logWarnS) "PeerMgr" $ 478 | "Could not connect to peer " <> p.label 479 | log_not_connect p (Just x) = 480 | $(logErrorS) "PeerMgr" $ 481 | "Could not connect to peer " 482 | <> p.label 483 | <> ": " 484 | <> cs (show x) 485 | 486 | announcePeer :: (MonadManager m, MonadLoggerIO m) => Peer -> m () 487 | announcePeer p = do 488 | b <- asks (.peers) 489 | atomically (findPeer b p) >>= \case 490 | Just OnlinePeer {online = True} -> do 491 | $(logInfoS) "PeerMgr" $ 492 | "Connected to peer " <> p.label 493 | managerEvent $ PeerConnected p 494 | logConnectedPeers 495 | Just OnlinePeer {online = False} -> 496 | return () 497 | Nothing -> 498 | $(logErrorS) "PeerMgr" $ 499 | "Not announcing disconnected peer: " 500 | <> p.label 501 | 502 | getNewPeer :: (MonadUnliftIO m, MonadManager m) => m (Maybe SockAddr) 503 | getNewPeer = 504 | runMaybeT $ lift loadPeers >> go 505 | where 506 | go = do 507 | b <- asks (.addresses) 508 | ks <- readTVarIO b 509 | guard . not $ Set.null ks 510 | let xs = Set.toList ks 511 | a <- liftIO $ randomRIO (0, length xs - 1) 512 | let p = xs !! a 513 | o <- asks (.peers) 514 | m <- atomically $ do 515 | modifyTVar b $ Set.delete p 516 | findPeerAddress o p 517 | maybe (return p) (const go) m 518 | 519 | connectPeer :: 520 | ( MonadUnliftIO m, 521 | MonadManager m, 522 | MonadLoggerIO m 523 | ) => 524 | SockAddr -> 525 | m () 526 | connectPeer sa = do 527 | os <- asks (.peers) 528 | atomically (findPeerAddress os sa) >>= \case 529 | Just _ -> 530 | $(logErrorS) "PeerMgr" $ 531 | "Attempted to connect to peer twice: " <> cs (show sa) 532 | Nothing -> do 533 | $(logInfoS) "PeerMgr" $ "Connecting to " <> cs (show sa) 534 | PeerMgrConfig 535 | { address = ad, 536 | net = net 537 | } <- 538 | asks (.config) 539 | sup <- asks (.supervisor) 540 | conn <- asks (.config.connect) 541 | pub <- asks (.config.pub) 542 | nonce <- liftIO randomIO 543 | bb <- getBestBlock 544 | now <- liftIO getCurrentTime 545 | let rmt = NetworkAddress (srv net) (sockToHostAddress sa) 546 | unix = floor (utcTimeToPOSIXSeconds now) 547 | ver = buildVersion net nonce bb ad rmt unix 548 | text = cs (show sa) 549 | (inbox, mailbox) <- newMailbox 550 | let pc = 551 | PeerConfig 552 | { pub = pub, 553 | net = net, 554 | label = text, 555 | connect = conn sa 556 | } 557 | busy <- newTVarIO False 558 | p <- wrapPeer pc busy mailbox 559 | a <- withRunInIO $ \io -> 560 | sup `addChild` io (launch pc busy inbox p) 561 | MVersion ver `sendMessage` p 562 | b <- asks (.peers) 563 | atomically $ 564 | insertPeer 565 | b 566 | OnlinePeer 567 | { address = sa, 568 | verack = False, 569 | online = False, 570 | version = Nothing, 571 | async = a, 572 | mailbox = p, 573 | nonce = nonce, 574 | pings = [], 575 | ping = Nothing, 576 | connected = now, 577 | tickled = now 578 | } 579 | where 580 | srv net 581 | | net.segWit = 8 582 | | otherwise = 0 583 | launch pc busy inbox p = 584 | ask >>= \mgr -> 585 | withPeerLoop p mgr $ \a -> 586 | link a >> peer pc busy inbox 587 | 588 | withPeerLoop :: 589 | (MonadUnliftIO m, MonadLogger m) => 590 | Peer -> 591 | PeerMgr -> 592 | (Async a -> m a) -> 593 | m a 594 | withPeerLoop p mgr = 595 | withAsync . forever $ do 596 | let timeout = mgr.config.timeout 597 | ms = floor (timeout * 1000 * 1000) 598 | r <- liftIO $ randomRIO (ms `div` 4, ms `div` 2) 599 | threadDelay r 600 | managerCheck p mgr 601 | 602 | withConnectLoop :: 603 | (MonadUnliftIO m, MonadManager m) => 604 | m a -> 605 | m a 606 | withConnectLoop act = 607 | withAsync go $ \a -> 608 | link a >> act 609 | where 610 | go = forever $ do 611 | l <- length <$> getOnlinePeers 612 | x <- asks (.config.maxPeers) 613 | when (l < x) $ 614 | getNewPeer >>= mapM_ (\sa -> ask >>= managerConnect sa) 615 | delay <- 616 | liftIO $ 617 | randomRIO 618 | ( 100 * 1000, 619 | 10 * 500 * 1000 620 | ) 621 | threadDelay delay 622 | 623 | newPeer :: (MonadIO m, MonadManager m) => SockAddr -> m () 624 | newPeer sa = do 625 | b <- asks (.addresses) 626 | o <- asks (.peers) 627 | atomically $ 628 | findPeerAddress o sa >>= \case 629 | Just _ -> return () 630 | Nothing -> modifyTVar b $ Set.insert sa 631 | 632 | gotPong :: TVar [OnlinePeer] -> Word64 -> UTCTime -> Peer -> STM () 633 | gotPong b nonce now p = void . runMaybeT $ do 634 | o <- MaybeT (findPeer b p) 635 | (time, old_nonce) <- MaybeT (return o.ping) 636 | guard $ nonce == old_nonce 637 | let diff = now `diffUTCTime` time 638 | lift $ 639 | insertPeer 640 | b 641 | o 642 | { ping = Nothing, 643 | pings = sort $ take 11 $ diff : o.pings 644 | } 645 | 646 | setPeerPing :: TVar [OnlinePeer] -> Word64 -> UTCTime -> Peer -> STM () 647 | setPeerPing b nonce now p = 648 | modifyPeer b p $ \o -> o {ping = Just (now, nonce)} 649 | 650 | setPeerVersion :: 651 | TVar [OnlinePeer] -> 652 | Peer -> 653 | Version -> 654 | STM (Either PeerException OnlinePeer) 655 | setPeerVersion b p v = runExceptT $ do 656 | when (v.services .&. nodeNetwork == 0) $ 657 | throwError NotNetworkPeer 658 | ops <- lift $ readTVar b 659 | when (any ((v.nonce ==) . (.nonce)) ops) $ 660 | throwError PeerIsMyself 661 | lift (findPeer b p) >>= \case 662 | Nothing -> throwError UnknownPeer 663 | Just o -> do 664 | let n = 665 | o 666 | { version = Just v, 667 | online = o.verack 668 | } 669 | lift $ insertPeer b n 670 | return n 671 | 672 | setPeerVerAck :: TVar [OnlinePeer] -> Peer -> STM (Maybe OnlinePeer) 673 | setPeerVerAck b p = runMaybeT $ do 674 | o <- MaybeT $ findPeer b p 675 | let n = 676 | o 677 | { verack = True, 678 | online = isJust o.version 679 | } 680 | lift $ insertPeer b n 681 | return n 682 | 683 | findPeer :: TVar [OnlinePeer] -> Peer -> STM (Maybe OnlinePeer) 684 | findPeer b p = 685 | find ((== p) . (.mailbox)) 686 | <$> readTVar b 687 | 688 | insertPeer :: TVar [OnlinePeer] -> OnlinePeer -> STM () 689 | insertPeer b o = 690 | modifyTVar b $ \x -> sort . nub $ o : x 691 | 692 | modifyPeer :: 693 | TVar [OnlinePeer] -> 694 | Peer -> 695 | (OnlinePeer -> OnlinePeer) -> 696 | STM () 697 | modifyPeer b p f = 698 | findPeer b p >>= \case 699 | Nothing -> return () 700 | Just o -> insertPeer b $ f o 701 | 702 | removePeer :: TVar [OnlinePeer] -> Peer -> STM () 703 | removePeer b p = 704 | modifyTVar b $ 705 | filter ((/= p) . (.mailbox)) 706 | 707 | findPeerAsync :: 708 | TVar [OnlinePeer] -> 709 | Async () -> 710 | STM (Maybe OnlinePeer) 711 | findPeerAsync b a = 712 | find ((== a) . (.async)) 713 | <$> readTVar b 714 | 715 | findPeerAddress :: 716 | TVar [OnlinePeer] -> 717 | SockAddr -> 718 | STM (Maybe OnlinePeer) 719 | findPeerAddress b a = 720 | find ((== a) . (.address)) 721 | <$> readTVar b 722 | 723 | getPeers :: (MonadIO m) => PeerMgr -> m [OnlinePeer] 724 | getPeers = runReaderT getConnectedPeers 725 | 726 | getOnlinePeer :: 727 | (MonadIO m) => 728 | Peer -> 729 | PeerMgr -> 730 | m (Maybe OnlinePeer) 731 | getOnlinePeer p = 732 | runReaderT $ asks (.peers) >>= atomically . (`findPeer` p) 733 | 734 | managerCheck :: (MonadIO m) => Peer -> PeerMgr -> m () 735 | managerCheck p mgr = 736 | CheckPeer p `send` mgr.mailbox 737 | 738 | managerConnect :: (MonadIO m) => SockAddr -> PeerMgr -> m () 739 | managerConnect sa mgr = 740 | Connect sa `send` mgr.mailbox 741 | 742 | peerMgrBest :: (MonadIO m) => BlockHeight -> PeerMgr -> m () 743 | peerMgrBest bh mgr = 744 | ManagerBest bh `send` mgr.mailbox 745 | 746 | peerMgrVerAck :: (MonadIO m) => Peer -> PeerMgr -> m () 747 | peerMgrVerAck p mgr = 748 | PeerVerAck p `send` mgr.mailbox 749 | 750 | peerMgrVersion :: 751 | (MonadIO m) => 752 | Peer -> 753 | Version -> 754 | PeerMgr -> 755 | m () 756 | peerMgrVersion p ver mgr = 757 | PeerVersion p ver `send` mgr.mailbox 758 | 759 | peerMgrPing :: 760 | (MonadIO m) => 761 | Peer -> 762 | Word64 -> 763 | PeerMgr -> 764 | m () 765 | peerMgrPing p nonce mgr = 766 | PeerPing p nonce `send` mgr.mailbox 767 | 768 | peerMgrPong :: 769 | (MonadIO m) => 770 | Peer -> 771 | Word64 -> 772 | PeerMgr -> 773 | m () 774 | peerMgrPong p nonce mgr = 775 | PeerPong p nonce `send` mgr.mailbox 776 | 777 | peerMgrAddrs :: 778 | (MonadIO m) => 779 | Peer -> 780 | [NetworkAddress] -> 781 | PeerMgr -> 782 | m () 783 | peerMgrAddrs p addrs mgr = 784 | PeerAddrs p addrs `send` mgr.mailbox 785 | 786 | toHostService :: String -> (Maybe String, Maybe String) 787 | toHostService str = 788 | let host = case m6 of 789 | Just (x, _) -> Just x 790 | Nothing -> case takeWhile (/= ':') str of 791 | [] -> Nothing 792 | xs -> Just xs 793 | srv = case m6 of 794 | Just (_, y) -> s y 795 | Nothing -> s str 796 | s xs = 797 | case dropWhile (/= ':') xs of 798 | [] -> Nothing 799 | _ : ys -> Just ys 800 | m6 = case str of 801 | (x : xs) 802 | | x == '[' -> do 803 | i <- elemIndex ']' xs 804 | return $ second tail $ splitAt i xs 805 | | x == ':' -> do 806 | return (str, "") 807 | _ -> Nothing 808 | in (host, srv) 809 | 810 | toSockAddr :: (MonadUnliftIO m) => Network -> String -> m [SockAddr] 811 | toSockAddr net str = 812 | go `catch` e 813 | where 814 | go = fmap (map addrAddress) $ liftIO $ getAddrInfo Nothing host srv 815 | (host, srv) = 816 | second (<|> Just (show net.defaultPort)) $ 817 | toHostService str 818 | e :: (Monad m) => SomeException -> m [SockAddr] 819 | e _ = return [] 820 | 821 | median :: (Ord a, Fractional a) => [a] -> Maybe a 822 | median ls 823 | | null ls = 824 | Nothing 825 | | even (length ls) = 826 | Just . (/ 2) . sum . take 2 $ 827 | drop (length ls `div` 2 - 1) ls' 828 | | otherwise = 829 | Just (ls' !! (length ls `div` 2)) 830 | where 831 | ls' = sort ls 832 | 833 | buildVersion :: 834 | Network -> 835 | Word64 -> 836 | BlockHeight -> 837 | NetworkAddress -> 838 | NetworkAddress -> 839 | Word64 -> 840 | Version 841 | buildVersion net nonce height loc rmt time = 842 | Version 843 | { version = myVersion, 844 | services = loc.services, 845 | timestamp = time, 846 | addrRecv = rmt, 847 | addrSend = loc, 848 | nonce = nonce, 849 | userAgent = VarString net.userAgent, 850 | startHeight = height, 851 | relay = True 852 | } 853 | 854 | myVersion :: Word32 855 | myVersion = 70012 856 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-23.21 2 | nix: 3 | packages: 4 | - rocksdb 5 | - secp256k1 6 | - zlib 7 | - pkg-config 8 | -------------------------------------------------------------------------------- /stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/topics/lock_files 5 | 6 | packages: [] 7 | snapshots: 8 | - completed: 9 | sha256: f4a61482dcad21151331bf84ec85bee9be43965f143791fa4bb202ac1e443e1b 10 | size: 683833 11 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/23/21.yaml 12 | original: lts-23.21 13 | -------------------------------------------------------------------------------- /test/Haskoin/NodeSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DuplicateRecordFields #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE OverloadedRecordDot #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE RecordWildCards #-} 8 | {-# LANGUAGE NoFieldSelectors #-} 9 | 10 | module Haskoin.NodeSpec (spec) where 11 | 12 | import Conduit 13 | ( awaitForever, 14 | concatMapC, 15 | foldC, 16 | mapMC, 17 | runConduit, 18 | takeCE, 19 | yield, 20 | (.|), 21 | ) 22 | import Control.Monad (forM_, forever, replicateM) 23 | import Control.Monad.Cont 24 | import Control.Monad.Logger (runNoLoggingT) 25 | import Control.Monad.Trans (lift) 26 | import Data.ByteString (ByteString) 27 | import qualified Data.ByteString as B 28 | import Data.ByteString.Base64 (decodeBase64Lenient) 29 | import Data.Default (def) 30 | import Data.Either (fromRight) 31 | import Data.List (find) 32 | import Data.Maybe (isJust, mapMaybe) 33 | import Data.Serialize (decode, get, runGet, runPut) 34 | import Data.Time.Clock.POSIX (getPOSIXTime) 35 | import qualified Database.RocksDB as R 36 | import Haskoin 37 | ( Block (..), 38 | BlockHash (..), 39 | BlockHeader (..), 40 | BlockNode (..), 41 | GetData (..), 42 | GetHeaders (..), 43 | Headers (..), 44 | InvType (..), 45 | InvVector (..), 46 | Message (..), 47 | MessageHeader (..), 48 | Network (..), 49 | NetworkAddress (..), 50 | Ping (..), 51 | Pong (..), 52 | VarInt (..), 53 | Version (..), 54 | bchRegTest, 55 | buildMerkleRoot, 56 | getMessage, 57 | headerHash, 58 | nodeNetwork, 59 | putMessage, 60 | sockToHostAddress, 61 | txHash, 62 | ) 63 | import Haskoin.Node 64 | import NQE 65 | ( Inbox, 66 | Mailbox, 67 | inboxToMailbox, 68 | newInbox, 69 | receive, 70 | receiveMatch, 71 | send, 72 | withPublisher, 73 | withSubscription, 74 | ) 75 | import Network.Socket (AddrInfo (addrAddress), SockAddr (..)) 76 | import System.Random (randomIO) 77 | import Test.Hspec 78 | import Test.Hspec.QuickCheck 79 | import UnliftIO 80 | ( MonadIO, 81 | MonadUnliftIO, 82 | liftIO, 83 | throwString, 84 | withAsync, 85 | withSystemTempDirectory, 86 | ) 87 | 88 | data TestNode = TestNode 89 | { testMgr :: PeerMgr, 90 | testChain :: Chain, 91 | nodeEvents :: Inbox NodeEvent 92 | } 93 | 94 | dummyPeerConnect :: 95 | Network -> 96 | NetworkAddress -> 97 | SockAddr -> 98 | WithConnection 99 | dummyPeerConnect net ad sa f = do 100 | r <- newInbox 101 | s <- newInbox 102 | let s' = inboxToMailbox s 103 | withAsync (go r s') $ \_ -> do 104 | let o = awaitForever (`send` r) 105 | i = forever (receive s >>= yield) 106 | f (Conduits i o) :: IO () 107 | where 108 | go :: Inbox ByteString -> Mailbox ByteString -> IO () 109 | go r s = do 110 | nonce <- randomIO 111 | now <- round <$> liftIO getPOSIXTime 112 | let rmt = NetworkAddress 0 (sockToHostAddress sa) 113 | ver = buildVersion net nonce 0 ad rmt now 114 | runPut (putMessage net (MVersion ver)) `send` s 115 | runConduit $ 116 | forever (receive r >>= yield) 117 | .| inc 118 | .| concatMapC mockPeerReact 119 | .| outc 120 | .| awaitForever (`send` s) 121 | outc = mapMC $ \msg -> return $ runPut (putMessage net msg) 122 | inc = 123 | forever $ do 124 | x <- takeCE 24 .| foldC 125 | y <- case decode x of 126 | Left _ -> error "Dummy peer not decode message header" 127 | Right (MessageHeader _ _ len _) -> 128 | takeCE (fromIntegral len) .| foldC 129 | case runGet (getMessage net) $ x `B.append` y of 130 | Left e -> 131 | error $ 132 | "Dummy peer could not decode payload: " <> show e 133 | Right msg -> yield msg 134 | 135 | mockPeerReact :: Message -> [Message] 136 | mockPeerReact (MPing (Ping n)) = [MPong (Pong n)] 137 | mockPeerReact (MVersion _) = [MVerAck] 138 | mockPeerReact (MGetHeaders (GetHeaders _ _hs _)) = [MHeaders (Headers hs')] 139 | where 140 | f b = (b.header, (VarInt . fromIntegral . length) b.txs) 141 | hs' = map f allBlocks 142 | mockPeerReact (MGetData (GetData ivs)) = mapMaybe f ivs 143 | where 144 | f (InvVector InvBlock h) = MBlock <$> find (l h) allBlocks 145 | f _ = Nothing 146 | l h b = headerHash b.header == BlockHash h 147 | mockPeerReact _ = [] 148 | 149 | spec :: Spec 150 | spec = do 151 | let net = bchRegTest 152 | describe "reads address/port combinations" $ do 153 | prop "reads arbitrary addresses" $ \(e, w1, w2, w3, w4, b) -> do 154 | let p = toEnum (e `mod` 65536) 155 | a = 156 | if b 157 | then SockAddrInet p w1 158 | else SockAddrInet6 p 0 (w1, w2, w3, w4) 0 159 | s <- head <$> toSockAddr net (show a) 160 | s `shouldBe` a 161 | it "reads some specific addresses" $ do 162 | toHostService "localhost" `shouldBe` (Just "localhost", Nothing) 163 | toHostService "::1" `shouldBe` (Just "::1", Nothing) 164 | toHostService "localhost:8080" `shouldBe` (Just "localhost", Just "8080") 165 | toHostService "example.com" `shouldBe` (Just "example.com", Nothing) 166 | toHostService "api.example.com:443" `shouldBe` (Just "api.example.com", Just "443") 167 | toHostService "api.example.com:http" `shouldBe` (Just "api.example.com", Just "http") 168 | toHostService "[::1]" `shouldBe` (Just "::1", Nothing) 169 | toHostService "[::1]:8080" `shouldBe` (Just "::1", Just "8080") 170 | toHostService "[2002::dead:beef]:ssh" `shouldBe` (Just "2002::dead:beef", Just "ssh") 171 | describe "peer manager on test network" $ do 172 | it "connects to a peer" $ 173 | withTestNode net "connect-one-peer" $ \TestNode {..} -> do 174 | p <- waitForPeer nodeEvents 175 | Just OnlinePeer {version = Just Version {version = ver}} <- 176 | getOnlinePeer p testMgr 177 | ver `shouldSatisfy` (>= 70002) 178 | it "downloads some blocks" $ 179 | withTestNode net "get-blocks" $ \TestNode {..} -> do 180 | let h1 = 181 | "3094ed3592a06f3d8e099eed2d9c1192329944f5df4a48acb29e08f12cfbb660" 182 | h2 = 183 | "0c89955fc5c9f98ecc71954f167b938138c90c6a094c4737f2e901669d26763f" 184 | p <- waitForPeer nodeEvents 185 | pbs <- getBlocks net 10 p [h1, h2] 186 | pbs `shouldSatisfy` isJust 187 | let Just [b1, b2] = pbs 188 | headerHash b1.header `shouldBe` h1 189 | headerHash b2.header `shouldBe` h2 190 | let ths b = map txHash b.txs 191 | testMerkle b = b.header.merkle `shouldBe` buildMerkleRoot (ths b) 192 | testMerkle b1 193 | testMerkle b2 194 | describe "chain on test network" $ do 195 | it "syncs some headers" $ 196 | withTestNode net "connect-sync" $ \TestNode {..} -> do 197 | let bh = 198 | "3bfa0c6da615fc45aa44ddea6854ac19d16f3ca167e0e21ac2cc262a49c9b002" 199 | ah = 200 | "7dc835a78a55fa76f9184dc4f6663a73e418c7afec789c5ae25e432fd7fc8467" 201 | bn <- 202 | receiveMatch nodeEvents $ \case 203 | ChainEvent (ChainBestBlock bn) 204 | | bn.height > 0 -> Just bn 205 | _ -> Nothing 206 | bb <- chainGetBest testChain 207 | bb.height `shouldSatisfy` (== 15) 208 | an <- 209 | maybe (throwString "No ancestor found") return 210 | =<< chainGetAncestor 10 bn testChain 211 | headerHash bn.header `shouldBe` bh 212 | headerHash an.header `shouldBe` ah 213 | it "downloads some block parents" $ 214 | withTestNode net "parents" $ \TestNode {..} -> do 215 | let hs = 216 | [ "52e886df7b166d961ac2d3d2d561d806325d51a609dc0a5d9d5fcb65d47906d7", 217 | "2537a081b9e2b24d217fac2886f387758cb3aa4e4956b3be7ed229bafbb71b0f", 218 | "7c72f306215a296f9714320a497b1f2cb5f9b99f162d7e04333c243fac9a54d8" 219 | ] 220 | [_, bn] <- 221 | replicateM 2 $ 222 | receiveMatch nodeEvents $ \case 223 | ChainEvent (ChainBestBlock bn) -> Just bn 224 | _ -> Nothing 225 | bn.height `shouldBe` 15 226 | ps <- chainGetParents 12 bn testChain 227 | length ps `shouldBe` 3 228 | forM_ (zip ps hs) $ \(p, h) -> 229 | headerHash p.header `shouldBe` h 230 | 231 | waitForPeer :: (MonadIO m) => Inbox NodeEvent -> m Peer 232 | waitForPeer inbox = 233 | receiveMatch inbox $ \case 234 | PeerEvent (PeerConnected p) -> Just p 235 | _ -> Nothing 236 | 237 | withTestNode :: 238 | (MonadUnliftIO m) => 239 | Network -> 240 | String -> 241 | (TestNode -> m a) -> 242 | m a 243 | withTestNode net str f = runNoLoggingT $ flip runContT return $ do 244 | w <- ContT $ withSystemTempDirectory ("haskoin-node-test-" <> str <> "-") 245 | pub <- ContT withPublisher 246 | sub <- ContT $ withSubscription pub 247 | db <- ContT $ R.withDBCF w cfg cols 248 | let ad = 249 | NetworkAddress 250 | nodeNetwork 251 | (sockToHostAddress (SockAddrInet 0 0)) 252 | na = 253 | NetworkAddress 254 | 0 255 | (sockToHostAddress (SockAddrInet 0 0)) 256 | cfg' = 257 | NodeConfig 258 | { maxPeers = 20, 259 | db = db, 260 | cf = Just (head (R.columnFamilies db)), 261 | peers = ["[::1]:17486"], 262 | discover = False, 263 | address = na, 264 | net = net, 265 | pub = pub, 266 | timeout = 120, 267 | maxPeerLife = 48 * 3600, 268 | connect = dummyPeerConnect net ad 269 | } 270 | Node mgr ch <- ContT $ withNode cfg' 271 | lift . lift $ 272 | f 273 | TestNode 274 | { testMgr = mgr, 275 | testChain = ch, 276 | nodeEvents = sub 277 | } 278 | where 279 | cfg = def {R.createIfMissing = True, R.errorIfExists = True} 280 | cols = [("node", def)] 281 | 282 | allBlocks :: [Block] 283 | allBlocks = 284 | fromRight (error "Could not decode blocks") $ 285 | runGet f (decodeBase64Lenient allBlocksBase64) 286 | where 287 | f = mapM (const get) [(1 :: Int) .. 15] 288 | 289 | allBlocksBase64 :: ByteString 290 | allBlocksBase64 = 291 | "AAAAIAYibkYRGgtZyq8SYEPrW78ow086XjMqH8eytzzxiJEPakRJalmWTFwdvzNuH8fHLZEjn+4N\ 292 | \FNMANdB7ez2M4a3TFbNe//9/IAMAAAABAgAAAAEAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA\ 293 | \AAAAAP////8MUQEBCC9FQjMyLjAv/////wEA8gUqAQAAACMhAwTspkCjMezKs47BPpafou1jjsHf\ 294 | \1OHjgkqxnwEYkK9zrAAAAAAAAAAge0RDjOrqVayGUoQsbNTJcTXUM+psaHpmuiFy6hwo2T8yn0CL\ 295 | \7WDJw9hxl1kf5c4JySq3WJF8OPsoguzF7mXH3tQVs17//38gAAAAAAECAAAAAQAAAAAAAAAAAAAA\ 296 | \AAAAAAAAAAAAAAAAAAAAAAAAAAAA/////wxSAQEIL0VCMzIuMC//////AQDyBSoBAAAAIyEDBOym\ 297 | \QKMx7MqzjsE+lp+i7WOOwd/U4eOCSrGfARiQr3OsAAAAAAAAACCKlhzDaFkrsmO2FhmeQS9ONS8D\ 298 | \QsU4H97yNxVhyIXYJuG3a9cyQpdeETjCQ6JybgkwI0OOfa4eYazf7WWI5UAk1BWzXv//fyAEAAAA\ 299 | \AQIAAAABAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAD/////DFMBAQgvRUIzMi4wL///\ 300 | \//8BAPIFKgEAAAAjIQME7KZAozHsyrOOwT6Wn6LtY47B39Th44JKsZ8BGJCvc6wAAAAAAAAAIP/S\ 301 | \XiIJZqvUyBY90z72dv6+/GG50R3vc3UAK8AHP89wChmkVP6nefjOt+sNyhbKk9zia47F08oTNtC0\ 302 | \OG1zyuXVFbNe//9/IAEAAAABAgAAAAEAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAP//\ 303 | \//8MVAEBCC9FQjMyLjAv/////wEA8gUqAQAAACMhAwTspkCjMezKs47BPpafou1jjsHf1OHjgkqx\ 304 | \nwEYkK9zrAAAAAAAAAAgeQtE1s3YV/uS2jUouo3S9DJAVf5OGk+Nyx+No1mPH24b5JCkr/tSP0E/\ 305 | \NYVkVcE0ZHxbO/fu5wOd+8VolvPQYtUVs17//38gAAAAAAECAAAAAQAAAAAAAAAAAAAAAAAAAAAA\ 306 | \AAAAAAAAAAAAAAAAAAAA/////wxVAQEIL0VCMzIuMC//////AQDyBSoBAAAAIyEDBOymQKMx7Mqz\ 307 | \jsE+lp+i7WOOwd/U4eOCSrGfARiQr3OsAAAAAAAAACBgtvss8QiesqxISt/1RJkykhGcLe2eCY49\ 308 | \b6CSNe2UMOVYGZ++uRCKvaJ2+jo7akr7XsdXCYSAmuw6DwSO8lvF1RWzXv//fyAAAAAAAQIAAAAB\ 309 | \AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAD/////DFYBAQgvRUIzMi4wL/////8BAPIF\ 310 | \KgEAAAAjIQME7KZAozHsyrOOwT6Wn6LtY47B39Th44JKsZ8BGJCvc6wAAAAAAAAAID92Jp1mAeny\ 311 | \N0dMCWoMyTiBk3sWT5VxzI75ycVflYkMCnXLFhuwrMdBbZmXJinAJBUpN7BV0XvlM2PRmb7HQebV\ 312 | \FbNe//9/IAEAAAABAgAAAAEAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAP////8MVwEB\ 313 | \CC9FQjMyLjAv/////wEA8gUqAQAAACMhAwTspkCjMezKs47BPpafou1jjsHf1OHjgkqxnwEYkK9z\ 314 | \rAAAAAAAAAAgxEgEkhjf5p+ql8dETmdSCdCdk+vB26+V2SGLEuE1+kA1acGCdQoQBqec8P/knItJ\ 315 | \M213OIrDX6U5IB6fgIas7dYVs17//38gAQAAAAECAAAAAQAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA\ 316 | \AAAAAAAAAAAA/////wxYAQEIL0VCMzIuMC//////AQDyBSoBAAAAIyEDBOymQKMx7MqzjsE+lp+i\ 317 | \7WOOwd/U4eOCSrGfARiQr3OsAAAAAAAAACDku4EB5X7htWpHg+aMzzW1AABttpNQTew7K3Aj2fh/\ 318 | \OuOCPhJApmcXq5o42tkksFSuhYvcfqaSHCuuFgjo6ohz1hWzXv//fyAAAAAAAQIAAAABAAAAAAAA\ 319 | \AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAD/////DFkBAQgvRUIzMi4wL/////8BAPIFKgEAAAAj\ 320 | \IQME7KZAozHsyrOOwT6Wn6LtY47B39Th44JKsZ8BGJCvc6wAAAAAAAAAIKWpAhOWbkEN9vWf1uCu\ 321 | \eXtVOZIE9V1OE87iC+H9atBRtY4LPgaWUSVMNh9SeZK1NViIFMklbjsfqYiC4eA/VuLWFbNe//9/\ 322 | \IAAAAAABAgAAAAEAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAP////8MWgEBCC9FQjMy\ 323 | \LjAv/////wEA8gUqAQAAACMhAwTspkCjMezKs47BPpafou1jjsHf1OHjgkqxnwEYkK9zrAAAAAAA\ 324 | \AAAgZ4T81y9DXuJanHjsr8cY5HM6ZvbETRj5dvpViqc1yH0oN9OOruaO5mjdITJwweVCzjSQ5Wsl\ 325 | \vSOKaKvEX5j9l9YVs17//38gAAAAAAECAAAAAQAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA\ 326 | \AAAA/////wxbAQEIL0VCMzIuMC//////AQDyBSoBAAAAIyEDBOymQKMx7MqzjsE+lp+i7WOOwd/U\ 327 | \4eOCSrGfARiQr3OsAAAAAAAAACCV3J2A3qneSJ7Q/RuF8OPd8O1izIXvKElR/xg/+InGNEafu0Ul\ 328 | \3VYJR93zbAQuns9hUfAhA8MTBPk8bbDabDfo1hWzXv//fyAAAAAAAQIAAAABAAAAAAAAAAAAAAAA\ 329 | \AAAAAAAAAAAAAAAAAAAAAAAAAAD/////DFwBAQgvRUIzMi4wL/////8BAPIFKgEAAAAjIQME7KZA\ 330 | \ozHsyrOOwT6Wn6LtY47B39Th44JKsZ8BGJCvc6wAAAAAAAAAINcGedRly1+dXQrcCaZRXTIG2GHV\ 331 | \0tPCGpZtFnvfhuhSx8d3Azdv/MXRJgsb56qqmD5gsXiWUdi7ia7wsBZVylvWFbNe//9/IAEAAAAB\ 332 | \AgAAAAEAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAP////8MXQEBCC9FQjMyLjAv////\ 333 | \/wEA8gUqAQAAACMhAwTspkCjMezKs47BPpafou1jjsHf1OHjgkqxnwEYkK9zrAAAAAAAAAAgDxu3\ 334 | \+7op0n6+s1ZJTqqzjHWH84YorH8hTbLiuYGgNyWIkhaj0zR7Vc+fSRm4UYUaPsefRhq3fUt8glyS\ 335 | \D8P/5tcVs17//38gAwAAAAECAAAAAQAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA////\ 336 | \/wxeAQEIL0VCMzIuMC//////AQDyBSoBAAAAIyEDBOymQKMx7MqzjsE+lp+i7WOOwd/U4eOCSrGf\ 337 | \ARiQr3OsAAAAAAAAACDYVJqsPyQ8MwR+LRafufm1LB97SQoyFJdvKVohBvNyfD4/FxT2i0rlYQcS\ 338 | \TQAvTnehousK2P8T9c0qx4Yj72lT1xWzXv//fyAAAAAAAQIAAAABAAAAAAAAAAAAAAAAAAAAAAAA\ 339 | \AAAAAAAAAAAAAAAAAAD/////DF8BAQgvRUIzMi4wL/////8BAPIFKgEAAAAjIQME7KZAozHsyrOO\ 340 | \wT6Wn6LtY47B39Th44JKsZ8BGJCvc6wAAAAA" 341 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | --------------------------------------------------------------------------------