diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -4,243 +4,358 @@ The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/) and this project adheres to [Semantic Versioning](http://semver.org/spec/v2.0.0.html). -## 0.18.1 +## [1.0.0] - 2023-07-28 + +### Changed + +- Make compatible with latest haskoin-core. +- Use DuplicateRecordFields and OverloadedRecordDot. +- Simplify pub/sub queues. +- Multiple refactoring passes. + +## [0.18.1] - 2022-07-27 + ### Fixed + - Set default port for peers where it is unset. -## 0.18.0 +## [0.18.0] - 2022-07-27 + ### Added + - Support setting up and connecting to IPv6 peers. -## 0.17.14 +## [0.17.14] - 2021-08-14 + ### Fixed + - Reduce verbosity on incoming header decode test. - Show appropriate error message upon receiving empty headers. -## 0.17.13 +## [0.17.13] - 2021-08-14 + ### Added + - Display more details about invalid incoming headers. -## 0.17.12 +## [0.17.12] - 2021-05-17 + ### Fixed + - Do not connect to more than the maximum number of peers. -## 0.17.11 +## [0.17.11] - 2021-05-17 + ### Added + - Display message command that disconnects a peer. -## 0.17.10 +## [0.17.10] - 2021-05-17 + ### Fixed + - Correct disconnect timeout algorithm bug. -## 0.17.9 +## [0.17.9] - 2021-05-17 + ### Fixed + - Add randomised timeouts to avoid disconnecting all peers. -## 0.17.2 +## [0.17.2] - 2021-03-09 + ### Fixed + - Do not start chain actor until database initialized. -## 0.17.1 +## [0.17.1] - 2021-01-08 + ### Changed + - Depend on haskoin-core-0.17.3. -## 0.17.0 +## [0.17.0] - 2020-10-21 + ### Added + - Support for Bitcoin Cash November 2020 hard fork. - BlockHeaders instance for ReaderT Chain. -## 0.16.0 +## [0.16.0] - 2020-07-23 + ### Changed + - Add support for column families. -## 0.15.0 +## [0.15.0] - 2020-07-20 + ### Changed + - Use new Haskell bindings for RocksDB. -## 0.14.1 +## [0.14.1] - 2020-06-19 + ### Fixed + - Correct flawed peer locking logic in Chain actor. -## 0.14.0 +## [0.14.0] - 2020-06-18 + ### Changed + - Massively refactor everything in a non-backwards-compatible way. - Use MIT license. - Bump haskoin-core. - Bump secp256k1-haskell. ### Fixed + - Fix getting stuck on a single peer. -## 0.13.0 +## [0.13.0] - 2020-05-08 + ### Changed + - Depend on Haskoin Store 0.13.3. - Better code organisation. -## 0.12.0 +## [0.12.0] - 2020-05-06 + ### Changed + - Add a test suite that simulates network instead of connecting to real one. -## 0.11.3 +## [0.11.3] - 2020-05-03 + ### Changed + - Revert including multiline decoding error text in logs. -## 0.11.2 +## [0.11.2] - 2020-05-03 + ### Changed + - Include header decoding error text in logs. -## 0.11.1 +## [0.11.1] - 2020-05-03 + ### Changed + - Improve logging. -## 0.11.0 +## [0.11.0] - 2020-05-03 + ### Changed + - Set peer too old time -## 0.10.1 +## [0.10.1] - 2020-05-03 + ### Changed + - Disconnect old peers after 48 hours instead of 30 minutes. -## 0.10.0 +## [0.10.0] - 2020-05-03 + ### Changed + - Move modules out of Network.Haskoin namespace. - Add better and more logging. - Change Manager module name and related values to PeerManager. -## 0.9.21 +## [0.9.21] - 2020-04-07 + ### Removed + - Remove unnecessary logging. -## 0.9.20 +## [0.9.20] - 2020-04-07 + ### Changed + - Better log messages. - Less verbose debug logging. -## 0.9.19 +## [0.9.19] - 2020-04-07 + ### Changed - Better log messages. -## 0.9.18 +## [0.9.18] - 2020-04-07 + ### Added + - More aggressive peer discovery. -## 0.9.17 +## [0.9.17] - 2020-04-07 + ### Added + - Peers are disconnected automatically after awhile. -## 0.9.16 +## [0.9.16] - 2020-02-08 + ### Added + - Lower bound versions for some dependencies. -## 0.9.15 +## [0.9.15] - 2020-01-15 + ### Changed + - Update to support new `NetworkAddress` data structure from `haskoin-core`. -## 0.9.14 +## [0.9.14] - 2019-12-10 + ### Removed + - No longer support storing peers in db as performance tradeoff doesn't justify it. -## 0.9.13 +## [0.9.13] - 2019-10-08 + ### Changed + - Really store peers in db. -## 0.9.12 +## [0.9.12] - 2019-10-08 + ### Changed + - Demote some logging to debug level. -## 0.9.11 +## [0.9.11] - 2019-10-02 + ### Added + - Add `-O2` optimisations to GHC. -## 0.9.10 +## [0.9.10] - 2019-04-19 + ### Added + - Increase debugging information where application freezes. -## 0.9.9 +## [0.9.9] - 2019-04-12 + ### Added + - Increase debugging information. -## 0.9.8 +## [0.9.8] - 2019-04-12 + ### Changed + - Increase version of haskoin-core to 0.9.0. - Fix some tests. -## 0.9.7 +## [0.9.7] - 2019-04-12 + ### Added + - More debugging. ### Changed + - Be defensive against duplicate peers. - Increase interval between housekeeping pings. - Replace peers in database atomically. -## 0.9.6 +## [0.9.6] - 2019-04-01 + ### Changed + - Randomize known peers instead of keeping scores. - Simplify peer management code to avoid freezes. - Merge logic for chain and manager. -## 0.9.5 +## [0.9.5] - 2018-11-14 + ### Changed + - Do not record new peers in database when peer discovery is disabled. -## 0.9.4 +## [0.9.4] - 2018-11-01 + ### Changed + - Don't spam best block events. -## 0.9.3 +## [0.9.3] - 2018-10-22 + ### Changed + - Correct display of milliseconds in log. - Correct bug when receiving headers from unknown peer. - Simplify chain syncing code. -## 0.9.2 +## [0.9.2] - 2018-10-18 + ### Changed + - Peer dies immediately when receiving a bad message. -## 0.9.1 +## [0.9.1] - 2018-10-18 + ### Changed + - Keep track of last synced header from a peer to avoid endless loops on large reorgs. -## 0.9.0 +## [0.9.0] - 2018-10-17 + ### Changed + - Use an STM listener instead of a publisher for the node API. -## 0.8.2 +## [0.8.2] - 2018-10-17 + ### Added + - Expose `ChainMessage` and `ManagerMessage` types from `Haskoin.Node` module. -## 0.8.1 +## [0.8.1] - 2018-10-11 + ### Changed + - Corrected documentation for `killPeer` function. - Leave time out of logic code. -## 0.8.0 +## [0.8.0] - 2018-10-09 + ### Changed + - Peers are now killed directly instead of through peer manager. ### Removed + - Chain no longer needs peer manager. -## 0.7.2 +## [0.7.2] - 2018-10-09 + ### Added + - Compatibility with base 4.12. ### Changed + - Update base to 4.9. -## 0.7.1 +## [0.7.1] - 2018-10-09 + ### Added + - Allow to easily obtain a peer's publisher. -## 0.7.0 +## [0.7.0] - 2018-10-09 + ### Added + - Versioning for chain and peer database. - Automatic purging of chain and peer database when version changes. - Add extra timers. - Add publishers to every peer. ### Changed + - Full reimplementation of node API. - Simplify peer selection and management. - Merge manager and peer events. @@ -248,6 +363,7 @@ - Separate logic from actors for peer manager and chain. ### Removed + - Remove irrelevant fields from peer information. - Remove unreliable peer block head tracking. - Remove dependency on deprecated binary conduits. @@ -255,33 +371,45 @@ - Remove unreliable peer request tracking code. - Remove separate manager events. -## 0.6.1 +## [0.6.1] - 2018-09-14 + ### Changed + - Fix bug where peer height did not update in certain cases. -## 0.6.0 +## [0.6.0] - 2018-09-14 + ### Added + - Documentation everywhere. ### Changed + - Make compatible with NQE 0.5. - Use supervisor only in peer manager. - API quality of life changes. - Exposed module is now only `Haskoin.Node`. ### Removed + - No more direct access to internals. -## 0.5.2 +## [0.5.2] - 2018-09-10 + ### Changed + - Improve dependency definitions. -## 0.5.1 +## [0.5.1] - 2018-09-10 + ### Changed + - Dependency `sec256k1` changes to `secp256k1-haskell`. -## 0.5.0 +## [0.5.0] - 2018-09-09 + ### Added + - New `CHANGELOG.md` file. - Use `nqe` for concurrency. - Peer discovery. @@ -289,11 +417,13 @@ - Support for Merkle blocks. ### Changed + - Split out of former `haskoin` repository. - Use hpack and `package.yaml`. - Old `haskoin-node` package now renamed to `old-haskoin-node` and deprecated. ### Removed + - Removed Old Haskoin Node package completely. - Removed Stylish Haskell configuration file. - Remvoed `haskoin-core` and `haskoin-wallet` packages from this repository. diff --git a/haskoin-node.cabal b/haskoin-node.cabal --- a/haskoin-node.cabal +++ b/haskoin-node.cabal @@ -1,13 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.35.1. +-- This file has been generated from package.yaml by hpack version 0.35.2. -- -- see: https://github.com/sol/hpack -- --- hash: a756b44df814f3c6d44c22345389b0b87b74ae7d921e18f027d27d41c1ad38ed +-- hash: 2f4be0a55ae78de70b6694a331bfa9338f4a9ac58590c07e9f7a044fe58fd9b9 name: haskoin-node -version: 0.19.0 +version: 1.0.0 synopsis: P2P library for Bitcoin and Bitcoin Cash description: Please see the README on GitHub at category: Bitcoin, Finance, Network @@ -31,8 +31,8 @@ Haskoin.Node other-modules: Haskoin.Node.Chain - Haskoin.Node.Manager Haskoin.Node.Peer + Haskoin.Node.PeerMgr Paths_haskoin_node hs-source-dirs: src @@ -45,7 +45,7 @@ , containers , data-default , hashable - , haskoin-core >=0.22.0 + , haskoin-core >=1.0.0 , monad-logger , mtl , network @@ -81,7 +81,7 @@ , containers , data-default , hashable - , haskoin-core >=0.22.0 + , haskoin-core >=1.0.0 , haskoin-node , hspec , monad-logger diff --git a/src/Haskoin/Node.hs b/src/Haskoin/Node.hs --- a/src/Haskoin/Node.hs +++ b/src/Haskoin/Node.hs @@ -1,190 +1,192 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NoFieldSelectors #-} + module Haskoin.Node - ( module Haskoin.Node.Peer - , module Haskoin.Node.Manager - , module Haskoin.Node.Chain - , NodeConfig (..) - , NodeEvent (..) - , Node (..) - , withNode - , withConnection - ) where + ( module Haskoin.Node.Peer, + module Haskoin.Node.PeerMgr, + module Haskoin.Node.Chain, + NodeConfig (..), + NodeEvent (..), + Node (..), + withNode, + withConnection, + ) +where -import Control.Monad (forever) -import Control.Monad.Logger (MonadLoggerIO) -import Data.Conduit.Network (appSink, appSource, clientSettings, - runTCPClient, ClientSettings) -import Data.String.Conversions (cs) -import Data.Time.Clock (NominalDiffTime) -import Database.RocksDB (ColumnFamily, DB) -import Haskoin (Addr (..), BlockNode (..), - Headers (..), Message (..), Network, - NetworkAddress, Ping (..), Pong (..)) -import Haskoin.Node.Chain -import Haskoin.Node.Manager -import Haskoin.Node.Peer -import Network.Socket (NameInfoFlag (..), SockAddr, - getNameInfo) -import NQE (Inbox, Publisher, publish, receive, - withPublisher, withSubscription) -import Text.Read (readMaybe) -import UnliftIO (MonadUnliftIO, SomeException, catch, - liftIO, link, throwIO, withAsync) +import Control.Monad (forever) +import Control.Monad.Cont (ContT (..), MonadCont (callCC), cont, lift, runCont, runContT) +import Control.Monad.Logger (MonadLoggerIO) +import Data.Conduit.Network + ( ClientSettings, + appSink, + appSource, + clientSettings, + runTCPClient, + ) +import Data.String.Conversions (cs) +import Data.Time.Clock (NominalDiffTime) +import Database.RocksDB (ColumnFamily, DB) +import Haskoin + ( Addr (..), + BlockNode (..), + Headers (..), + Message (..), + Network, + NetworkAddress, + Ping (..), + Pong (..), + ) +import Haskoin.Node.Chain +import Haskoin.Node.Peer +import Haskoin.Node.PeerMgr +import NQE + ( Inbox, + Publisher, + publish, + receive, + withPublisher, + withSubscription, + ) +import Network.Socket + ( NameInfoFlag (..), + SockAddr, + getNameInfo, + ) +import Text.Read (readMaybe) +import UnliftIO + ( MonadUnliftIO, + SomeException, + catch, + liftIO, + link, + throwIO, + withAsync, + ) -- | General node configuration. data NodeConfig = NodeConfig - { nodeConfMaxPeers :: !Int - -- ^ maximum number of connected peers allowed - , nodeConfDB :: !DB - -- ^ database handler - , nodeConfColumnFamily :: !(Maybe ColumnFamily) - -- ^ database column family - , nodeConfPeers :: ![String] - -- ^ static list of peers to connect to - , nodeConfDiscover :: !Bool - -- ^ activate peer discovery - , nodeConfNetAddr :: !NetworkAddress - -- ^ network address for the local host - , nodeConfNet :: !Network - -- ^ network constants - , nodeConfEvents :: !(Publisher NodeEvent) - -- ^ node events are sent to this publisher - , nodeConfTimeout :: !NominalDiffTime - -- ^ timeout in seconds - , nodeConfPeerMaxLife :: !NominalDiffTime - -- ^ peer disconnect after seconds - , nodeConfConnect :: !(SockAddr -> WithConnection) - } + { -- | maximum number of connected peers allowed + maxPeers :: !Int, + -- | database handler + db :: !DB, + -- | database column family + cf :: !(Maybe ColumnFamily), + -- | static list of peers to connect to + peers :: ![String], + -- | activate peer discovery + discover :: !Bool, + -- | network address for the local host + address :: !NetworkAddress, + -- | network constants + net :: !Network, + -- | node events are sent to this publisher + pub :: !(Publisher NodeEvent), + -- | timeout in seconds + timeout :: !NominalDiffTime, + -- | peer disconnect after seconds + maxPeerLife :: !NominalDiffTime, + connect :: !(SockAddr -> WithConnection) + } -data Node = Node { nodeManager :: !PeerManager - , nodeChain :: !Chain - } +data Node = Node + { peerMgr :: !PeerMgr, + chain :: !Chain + } data NodeEvent - = ChainEvent !ChainEvent - | PeerEvent !PeerEvent - | PeerMessage !Peer !Message - deriving Eq + = ChainEvent !ChainEvent + | PeerEvent !PeerEvent + deriving (Eq) withConnection :: SockAddr -> WithConnection withConnection na f = - fromSockAddr na >>= \case - Nothing -> throwIO PeerAddressInvalid - Just cset -> - runTCPClient cset $ \ad -> - f (Conduits (appSource ad) (appSink ad)) + fromSockAddr na >>= \case + Nothing -> throwIO PeerAddressInvalid + Just cset -> + runTCPClient cset $ \ad -> + f (Conduits (appSource ad) (appSink ad)) fromSockAddr :: - (MonadUnliftIO m) => SockAddr -> m (Maybe ClientSettings) + (MonadUnliftIO m) => SockAddr -> m (Maybe ClientSettings) fromSockAddr sa = go `catch` e where go = do - (maybe_host, maybe_port) <- liftIO (getNameInfo flags True True sa) - return $ - clientSettings - <$> (readMaybe =<< maybe_port) + (maybe_host, maybe_port) <- liftIO (getNameInfo flags True True sa) + return $ + clientSettings + <$> (readMaybe =<< maybe_port) <*> (cs <$> maybe_host) flags = [NI_NUMERICHOST, NI_NUMERICSERV] - e :: Monad m => SomeException -> m (Maybe a) + e :: (Monad m) => SomeException -> m (Maybe a) e _ = return Nothing -chainForwarder :: MonadLoggerIO m - => PeerManager - -> Publisher NodeEvent - -> Inbox ChainEvent - -> m () -chainForwarder mgr pub inbox = - forever $ receive inbox >>= \event -> do - case event of - ChainBestBlock bb -> - managerBest (nodeHeight bb) mgr - _ -> return () - publish (ChainEvent event) pub - -managerForwarder :: MonadLoggerIO m - => Chain - -> Publisher NodeEvent - -> Inbox PeerEvent - -> m () -managerForwarder ch pub inbox = - forever $ receive inbox >>= \event -> do - case event of - PeerConnected p -> - chainPeerConnected p ch - PeerDisconnected p -> - chainPeerDisconnected p ch - publish (PeerEvent event) pub +chainEvents :: + (MonadUnliftIO m, MonadLoggerIO m) => + PeerMgr -> + Inbox ChainEvent -> + Publisher NodeEvent -> + m () +chainEvents mgr input output = forever $ do + event <- receive input + case event of + ChainBestBlock bb -> + peerMgrBest bb.height mgr + _ -> return () + publish (ChainEvent event) output -peerForwarder :: MonadLoggerIO m - => Chain - -> PeerManager - -> Publisher NodeEvent - -> Inbox (Peer, Message) - -> m () -peerForwarder ch mgr pub inbox = - forever $ receive inbox >>= \(p, msg) -> do - case msg of - MVersion v -> - managerVersion p v mgr - MVerAck -> - managerVerAck p mgr - MPing (Ping n) -> - managerPing p n mgr - MPong (Pong n) -> - managerPong p n mgr - MAddr (Addr ns) -> - managerAddrs p (map snd ns) mgr - MHeaders (Headers hs) -> - chainHeaders p (map fst hs) ch - _ -> return () - managerTickle p mgr - publish (PeerMessage p msg) pub +peerEvents :: + (MonadUnliftIO m, MonadLoggerIO m) => + Chain -> + PeerMgr -> + Inbox PeerEvent -> + Publisher NodeEvent -> + m () +peerEvents ch mgr input output = forever $ do + event <- receive input + case event of + PeerConnected p -> + chainPeerConnected p ch + PeerDisconnected p -> + chainPeerDisconnected p ch + PeerMessage p msg -> do + case msg of + MVersion v -> + peerMgrVersion p v mgr + MVerAck -> + peerMgrVerAck p mgr + MPing (Ping n) -> + peerMgrPing p n mgr + MPong (Pong n) -> + peerMgrPong p n mgr + MAddr (Addr ns) -> + peerMgrAddrs p (map snd ns) mgr + MHeaders (Headers hs) -> + chainHeaders p (map fst hs) ch + _ -> return () + peerMgrTickle p mgr + publish (PeerEvent event) output -- | Launch node process in the foreground. withNode :: - ( MonadLoggerIO m - , MonadUnliftIO m - ) - => NodeConfig - -> (Node -> m a) - -> m a -withNode cfg action = - withPublisher $ \peer_pub -> - withPublisher $ \mgr_pub -> - withPublisher $ \ch_pub -> - withSubscription peer_pub $ \peer_inbox -> - withSubscription mgr_pub $ \mgr_inbox -> - withSubscription ch_pub $ \ch_inbox -> - withPeerManager (mgr_config mgr_pub peer_pub) $ \mgr -> - withChain (chain_config ch_pub) $ \ch -> - withAsync (peerForwarder ch mgr pub peer_inbox) $ \a -> - withAsync (managerForwarder ch pub mgr_inbox) $ \b -> - withAsync (chainForwarder mgr pub ch_inbox) $ \c -> - link a >> link b >> link c >> - action Node { nodeManager = mgr, nodeChain = ch } - where - pub = nodeConfEvents cfg - chain_config ch_pub = - ChainConfig - { chainConfDB = nodeConfDB cfg - , chainConfColumnFamily = nodeConfColumnFamily cfg - , chainConfNetwork = nodeConfNet cfg - , chainConfEvents = ch_pub - , chainConfTimeout = nodeConfTimeout cfg - } - mgr_config mgr_pub peer_pub = - PeerManagerConfig - { peerManagerMaxPeers = nodeConfMaxPeers cfg - , peerManagerPeers = nodeConfPeers cfg - , peerManagerDiscover = nodeConfDiscover cfg - , peerManagerNetAddr = nodeConfNetAddr cfg - , peerManagerNetwork = nodeConfNet cfg - , peerManagerEvents = mgr_pub - , peerManagerMaxLife = nodeConfPeerMaxLife cfg - , peerManagerTimeout = nodeConfTimeout cfg - , peerManagerConnect = nodeConfConnect cfg - , peerManagerPub = peer_pub - } + (MonadLoggerIO m, MonadUnliftIO m) => + NodeConfig -> + (Node -> m a) -> + m a +withNode NodeConfig {..} action = flip runContT return $ do + peerPub <- ContT withPublisher + peerSub <- ContT (withSubscription peerPub) + chainPub <- ContT withPublisher + chainSub <- ContT (withSubscription chainPub) + let peerMgrCfg = PeerMgrConfig {pub = peerPub, ..} + let chainCfg = ChainConfig {pub = chainPub, ..} + chain <- ContT (withChain chainCfg) + peerMgr <- ContT $ withPeerMgr peerMgrCfg + lift . link =<< ContT (withAsync $ chainEvents peerMgr chainSub pub) + lift . link =<< ContT (withAsync $ peerEvents chain peerMgr peerSub pub) + lift $ action Node {..} diff --git a/src/Haskoin/Node/Chain.hs b/src/Haskoin/Node/Chain.hs --- a/src/Haskoin/Node/Chain.hs +++ b/src/Haskoin/Node/Chain.hs @@ -1,683 +1,772 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Haskoin.Node.Chain - ( ChainConfig (..) - , ChainEvent (..) - , Chain - , withChain - , chainGetBlock - , chainGetBest - , chainGetAncestor - , chainGetParents - , chainGetSplitBlock - , chainPeerConnected - , chainPeerDisconnected - , chainIsSynced - , chainBlockMain - , chainHeaders - ) where - -import Control.Monad (forM_, forever, guard, when) -import Control.Monad.Except (runExceptT, throwError) -import Control.Monad.Logger (MonadLoggerIO, logDebugS, logErrorS, - logInfoS) -import Control.Monad.Reader (MonadReader, ReaderT (..), asks, - runReaderT) -import Control.Monad.Trans (lift) -import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) -import qualified Data.ByteString as B -import Data.Function (on) -import Data.List (delete, nub) -import Data.Maybe (isJust, isNothing) -import Data.Serialize (Serialize, get, getWord8, put, - putWord8) -import Data.String.Conversions (cs) -import Data.Time.Clock (NominalDiffTime, UTCTime, - diffUTCTime, getCurrentTime) -import Data.Time.Clock.POSIX (posixSecondsToUTCTime, - utcTimeToPOSIXSeconds) -import Data.Word (Word32) -import Database.RocksDB (ColumnFamily, DB) -import qualified Database.RocksDB as R -import Database.RocksDB.Query (Key, KeyValue, insert, insertCF, - insertOp, insertOpCF, - retrieveCommon, writeBatch) -import Haskoin (BlockHash, BlockHeader (..), - BlockHeaders (..), BlockHeight, - BlockNode (..), GetHeaders (..), - Message (..), Network, blockLocator, - connectBlocks, genesisNode, - getAncestor, headerHash, splitPoint) -import Haskoin.Node.Manager (myVersion) -import Haskoin.Node.Peer -import NQE (Mailbox, Publisher, newMailbox, - publish, receive, send) -import System.Random (randomRIO) -import UnliftIO (MonadIO, MonadUnliftIO, TVar, - atomically, liftIO, link, - modifyTVar, newTVarIO, readTVar, - readTVarIO, withAsync, writeTVar) -import UnliftIO.Concurrent (threadDelay) - --- | Mailbox for chain header syncing process. -data Chain = Chain { chainMailbox :: !(Mailbox ChainMessage) - , chainReader :: !ChainReader - } - -instance Eq Chain where - (==) = (==) `on` chainMailbox - --- | Configuration for chain syncing process. -data ChainConfig = - ChainConfig - { chainConfDB :: !DB - -- ^ database handle - , chainConfColumnFamily :: !(Maybe ColumnFamily) - -- ^ column family - , chainConfNetwork :: !Network - -- ^ network constants - , chainConfEvents :: !(Publisher ChainEvent) - -- ^ send header chain events here - , chainConfTimeout :: !NominalDiffTime - -- ^ timeout in seconds - } - -data ChainMessage - = ChainHeaders !Peer ![BlockHeader] - | ChainPeerConnected !Peer - | ChainPeerDisconnected !Peer - | ChainPing - --- | Events originating from chain syncing process. -data ChainEvent - = ChainBestBlock !BlockNode - -- ^ chain has new best block - | ChainSynced !BlockNode - -- ^ chain is in sync with the network - deriving (Eq, Show) - -type MonadChain m = - ( MonadLoggerIO m - , MonadUnliftIO m - , MonadReader ChainReader m ) - --- | Reader for header synchronization code. -data ChainReader = ChainReader - { myConfig :: !ChainConfig - -- ^ placeholder for upstream data - , chainState :: !(TVar ChainState) - -- ^ mutable state for header synchronization - } - --- | Database key for version. -data ChainDataVersionKey = ChainDataVersionKey - deriving (Eq, Ord, Show) - -instance Key ChainDataVersionKey -instance KeyValue ChainDataVersionKey Word32 - -instance Serialize ChainDataVersionKey where - get = do - guard . (== 0x92) =<< getWord8 - return ChainDataVersionKey - put ChainDataVersionKey = putWord8 0x92 - -data ChainSync = ChainSync - { chainSyncPeer :: !Peer - , chainTimestamp :: !UTCTime - , chainHighest :: !(Maybe BlockNode) - } - --- | Mutable state for the header chain process. -data ChainState = ChainState - { chainSyncing :: !(Maybe ChainSync) - -- ^ peer to sync against and time of last received message - , newPeers :: ![Peer] - -- ^ queue of peers to sync against - , mySynced :: !Bool - -- ^ has the header chain ever been considered synced? - } - --- | Key for block header in database. -newtype BlockHeaderKey = BlockHeaderKey BlockHash deriving (Eq, Show) - -instance Serialize BlockHeaderKey where - get = do - guard . (== 0x90) =<< getWord8 - BlockHeaderKey <$> get - put (BlockHeaderKey bh) = do - putWord8 0x90 - put bh - --- | Key for best block in database. -data BestBlockKey = BestBlockKey deriving (Eq, Show) - -instance KeyValue BlockHeaderKey BlockNode -instance KeyValue BestBlockKey BlockNode - -instance Serialize BestBlockKey where - get = do - guard . (== 0x91) =<< getWord8 - return BestBlockKey - put BestBlockKey = putWord8 0x91 - -instance MonadIO m => BlockHeaders (ReaderT ChainConfig m) where - addBlockHeader bn = do - db <- asks chainConfDB - asks chainConfColumnFamily >>= \case - Nothing -> insert db (BlockHeaderKey h) bn - Just cf -> insertCF db cf (BlockHeaderKey h) bn - where - h = headerHash (nodeHeader bn) - getBlockHeader bh = do - db <- asks chainConfDB - mcf <- asks chainConfColumnFamily - retrieveCommon db mcf (BlockHeaderKey bh) - getBestBlockHeader = do - db <- asks chainConfDB - mcf <- asks chainConfColumnFamily - retrieveCommon db mcf BestBlockKey >>= \case - Nothing -> error "Could not get best block from database" - Just b -> return b - setBestBlockHeader bn = do - db <- asks chainConfDB - asks chainConfColumnFamily >>= \case - Nothing -> insert db BestBlockKey bn - Just cf -> insertCF db cf BestBlockKey bn - addBlockHeaders bns = do - db <- asks chainConfDB - mcf <- asks chainConfColumnFamily - writeBatch db (map (f mcf) bns) - where - h bn = headerHash (nodeHeader bn) - f Nothing bn = insertOp (BlockHeaderKey (h bn)) bn - f (Just cf) bn = insertOpCF cf (BlockHeaderKey (h bn)) bn - -instance MonadIO m => BlockHeaders (ReaderT Chain m) where - getBlockHeader bh = ReaderT $ chainGetBlock bh - getBestBlockHeader = ReaderT chainGetBest - addBlockHeader _ = undefined - setBestBlockHeader _ = undefined - addBlockHeaders _ = undefined - -withBlockHeaders :: MonadChain m => ReaderT ChainConfig m a -> m a -withBlockHeaders f = do - cfg <- asks myConfig - runReaderT f cfg - -withChain :: - (MonadUnliftIO m, MonadLoggerIO m) - => ChainConfig - -> (Chain -> m a) - -> m a -withChain cfg action = do - (inbox, mailbox) <- newMailbox - $(logDebugS) "Chain" "Starting chain actor" - st <- newTVarIO ChainState { chainSyncing = Nothing - , mySynced = False - , newPeers = [] - } - let rd = ChainReader { myConfig = cfg - , chainState = st - } - ch = Chain { chainReader = rd - , chainMailbox = mailbox - } - runReaderT initChainDB rd - withAsync (main_loop ch rd inbox) $ \a -> - link a >> action ch - where - main_loop ch rd inbox = withSyncLoop ch $ - runReaderT (run inbox) rd - run inbox = do - withBlockHeaders getBestBlockHeader >>= - chainEvent . ChainBestBlock - forever $ do - msg <- receive inbox - chainMessage msg - -chainEvent :: MonadChain m => ChainEvent -> m () -chainEvent e = do - pub <- asks (chainConfEvents . myConfig) - case e of - ChainBestBlock b -> - $(logInfoS) "Chain" $ - "Best block header at height: " - <> cs (show (nodeHeight b)) - ChainSynced b -> - $(logInfoS) "Chain" $ - "Headers in sync at height: " - <> cs (show (nodeHeight b)) - publish e pub - -processHeaders :: MonadChain m => Peer -> [BlockHeader] -> m () -processHeaders p hs = do - $(logDebugS) "Chain" $ - "Processing " <> cs (show (length hs)) - <> " headers from peer: " <> peerText p - net <- asks (chainConfNetwork . myConfig) - now <- liftIO getCurrentTime - pbest <- withBlockHeaders getBestBlockHeader - importHeaders net now hs >>= \case - Left e -> do - $(logErrorS) "Chain" $ - "Could not connect headers from peer: " - <> peerText p - e `killPeer` p - Right done -> do - setLastReceived - best <- withBlockHeaders getBestBlockHeader - when (nodeHeader pbest /= nodeHeader best) $ - chainEvent (ChainBestBlock best) - if done - then do - MSendHeaders `sendMessage` p - finishPeer p - syncNewPeer - syncNotif - else syncPeer p - -syncNewPeer :: MonadChain m => m () -syncNewPeer = getSyncingPeer >>= \case - Just _ -> return () - Nothing -> nextPeer >>= \case - Nothing -> return () - Just p -> do - $(logDebugS) "Chain" $ - "Syncing against peer: " <> peerText p - syncPeer p - -syncNotif :: MonadChain m => m () -syncNotif = - notifySynced >>= \case - False -> return () - True -> withBlockHeaders getBestBlockHeader >>= - chainEvent . ChainSynced - -syncPeer :: MonadChain m => Peer -> m () -syncPeer p = do - t <- liftIO getCurrentTime - m <- chainSyncingPeer >>= \case - Just ChainSync { chainSyncPeer = s - , chainHighest = m - } - | p == s -> syncing_me t m - | otherwise -> return Nothing - Nothing -> syncing_new t - forM_ m $ \g -> do - $(logDebugS) "Chain" $ - "Requesting headers from peer: " - <> peerText p - MGetHeaders g `sendMessage` p - where - syncing_new t = - setSyncingPeer p >>= \case - False -> return Nothing - True -> do - $(logDebugS) "Chain" $ - "Locked peer: " <> peerText p - h <- withBlockHeaders getBestBlockHeader - Just <$> syncHeaders t h p - syncing_me t m = do - h <- case m of - Nothing -> withBlockHeaders getBestBlockHeader - Just h -> return h - Just <$> syncHeaders t h p - -chainMessage :: MonadChain m => ChainMessage -> m () - -chainMessage (ChainHeaders p hs) = - processHeaders p hs - -chainMessage (ChainPeerConnected p) = do - $(logDebugS) "Chain" $ "Peer connected: " <> peerText p - addPeer p - syncNewPeer - -chainMessage (ChainPeerDisconnected p) = do - $(logDebugS) "Chain" $ "Peer disconnected: " <> peerText p - finishPeer p - syncNewPeer - -chainMessage ChainPing = do - to <- asks (chainConfTimeout . myConfig) - now <- liftIO getCurrentTime - chainSyncingPeer >>= \case - Just ChainSync {chainSyncPeer = p, chainTimestamp = t} - | now `diffUTCTime` t > to -> do - $(logErrorS) "Chain" $ - "Syncing peer timed out: " <> peerText p - PeerTimeout `killPeer` p - | otherwise -> return () - Nothing -> syncNewPeer - -withSyncLoop :: (MonadUnliftIO m, MonadLoggerIO m) - => Chain -> m a -> m a -withSyncLoop ch f = - withAsync go $ \a -> - link a >> f - where - go = forever $ do - delay <- liftIO $ - randomRIO ( 2 * 1000 * 1000 - , 20 * 1000 * 1000 ) - threadDelay delay - ChainPing `send` chainMailbox ch - --- | Version of the database. -dataVersion :: Word32 -dataVersion = 1 - --- | Initialize header database. If version is different from current, the --- database is purged of conflicting elements first. -initChainDB :: MonadChain m => m () -initChainDB = do - db <- asks (chainConfDB . myConfig) - mcf <- asks (chainConfColumnFamily . myConfig) - net <- asks (chainConfNetwork . myConfig) - ver <- retrieveCommon db mcf ChainDataVersionKey - when (ver /= Just dataVersion) $ purgeChainDB >>= writeBatch db - case mcf of - Nothing -> insert db ChainDataVersionKey dataVersion - Just cf -> insertCF db cf ChainDataVersionKey dataVersion - retrieveCommon db mcf BestBlockKey >>= \b -> - when (isNothing (b :: Maybe BlockNode)) $ - withBlockHeaders $ do - addBlockHeader (genesisNode net) - setBestBlockHeader (genesisNode net) - --- | Purge database of elements having keys that may conflict with those used in --- this module. -purgeChainDB :: MonadChain m => m [R.BatchOp] -purgeChainDB = do - db <- asks (chainConfDB . myConfig) - mcf <- asks (chainConfColumnFamily . myConfig) - f db mcf $ \it -> do - R.iterSeek it $ B.singleton 0x90 - recurse_delete it db mcf - where - f db Nothing = R.withIter db - f db (Just cf) = R.withIterCF db cf - recurse_delete it db mcf = - R.iterKey it >>= \case - Just k - | B.head k == 0x90 || B.head k == 0x91 -> do - case mcf of - Nothing -> R.delete db k - Just cf -> R.deleteCF db cf k - R.iterNext it - (R.Del k :) <$> recurse_delete it db mcf - _ -> return [] - --- | Import a bunch of continuous headers. Returns 'True' if the number of --- headers is 2000, which means that there are possibly more headers to sync --- from whatever peer delivered these. -importHeaders :: MonadChain m - => Network - -> UTCTime - -> [BlockHeader] - -> m (Either PeerException Bool) -importHeaders net now hs = - runExceptT $ - lift connect >>= \case - Right _ -> do - case hs of - [] -> return () - _ -> do - bb <- lift get_last - box <- asks chainState - atomically . modifyTVar box $ \s -> - s { chainSyncing = - (\x -> x {chainHighest = bb}) - <$> chainSyncing s - } - case length hs of - 2000 -> return False - _ -> return True - Left _ -> throwError PeerSentBadHeaders - where - timestamp = floor (utcTimeToPOSIXSeconds now) - connect = withBlockHeaders $ connectBlocks net timestamp hs - get_last = withBlockHeaders . getBlockHeader . headerHash $ last hs - --- | Check if best block header is in sync with the rest of the block chain by --- comparing the best block with the current time, verifying that there are no --- peers in the queue to be synced, and no peer is being synced at the moment. --- This function will only return 'True' once. It should be used to decide --- whether to notify other processes that the header chain has been synced. The --- state of the chain will be flipped to synced when this function returns --- 'True'. -notifySynced :: MonadChain m => m Bool -notifySynced = - fmap isJust $ - runMaybeT $ do - bb <- lift $ withBlockHeaders getBestBlockHeader - now <- liftIO getCurrentTime - guard $ now `diffUTCTime` block_time bb > 7200 - st <- asks chainState - MaybeT . atomically . runMaybeT $ do - s <- lift $ readTVar st - guard . isNothing $ chainSyncing s - guard . null $ newPeers s - guard . not $ mySynced s - lift $ writeTVar st s {mySynced = True} - return () - where - block_time = - posixSecondsToUTCTime . fromIntegral . blockTimestamp . nodeHeader - --- | Get next peer to sync against from the queue. -nextPeer :: MonadChain m => m (Maybe Peer) -nextPeer = do - ps <- newPeers <$> (readTVarIO =<< asks chainState) - go ps - where - go [] = return Nothing - go (p:ps) = - setSyncingPeer p >>= \case - True -> return (Just p) - False -> go ps - --- | Set a syncing peer and generate a 'GetHeaders' data structure with a block --- locator to send to that peer for syncing. -syncHeaders :: - MonadChain m - => UTCTime - -> BlockNode - -> Peer - -> m GetHeaders -syncHeaders now bb p = do - st <- asks chainState - atomically $ - modifyTVar st $ \s -> - s { chainSyncing = - Just - ChainSync - { chainSyncPeer = p - , chainTimestamp = now - , chainHighest = Nothing - } - , newPeers = delete p (newPeers s) - } - loc <- withBlockHeaders $ blockLocator bb - return - GetHeaders - { getHeadersVersion = myVersion - , getHeadersBL = loc - , getHeadersHashStop = z - } - where - z = "0000000000000000000000000000000000000000000000000000000000000000" - --- | Set the time of last received data to now if a syncing peer is active. -setLastReceived :: MonadChain m => m () -setLastReceived = do - now <- liftIO getCurrentTime - st <- asks chainState - let f p = p { chainTimestamp = now } - atomically . modifyTVar st $ \s -> - s { chainSyncing = f <$> chainSyncing s } - --- | Add a new peer to the queue of peers to sync against. -addPeer :: MonadChain m => Peer -> m () -addPeer p = do - st <- asks chainState - atomically . modifyTVar st $ \s -> s {newPeers = nub (p : newPeers s)} - --- | Get syncing peer if there is one. -getSyncingPeer :: MonadChain m => m (Maybe Peer) -getSyncingPeer = - fmap chainSyncPeer . chainSyncing <$> (readTVarIO =<< asks chainState) - -setSyncingPeer :: MonadChain m => Peer -> m Bool -setSyncingPeer p = - setBusy p >>= \case - False -> do - $(logDebugS) "Chain" $ - "Could not lock peer: " <> peerText p - return False - True -> do - $(logDebugS) "Chain" $ - "Locked peer: " <> peerText p - set_it - return True - where - set_it = do - now <- liftIO getCurrentTime - box <- asks chainState - atomically $ modifyTVar box $ \s -> - s { chainSyncing = - Just ChainSync { chainSyncPeer = p - , chainTimestamp = now - , chainHighest = Nothing - } - } - - --- | Remove a peer from the queue of peers to sync and unset the syncing peer if --- it is set to the provided peer. -finishPeer :: MonadChain m => Peer -> m () -finishPeer p = - asks chainState >>= remove_peer >>= \case - False -> - $(logDebugS) "Chain" $ - "Removed peer from queue: " <> peerText p - True -> do - $(logDebugS) "Chain" $ - "Releasing syncing peer: " <> peerText p - setFree p - where - remove_peer st = atomically $ - readTVar st >>= \s -> case chainSyncing s of - Just ChainSync { chainSyncPeer = p' } - | p == p' -> do - unset_syncing st - return True - _ -> do - remove_from_queue st - return False - unset_syncing st = - modifyTVar st $ \x -> - x { chainSyncing = Nothing } - remove_from_queue st = - modifyTVar st $ \x -> - x { newPeers = delete p (newPeers x) } - --- | Return syncing peer data. -chainSyncingPeer :: MonadChain m => m (Maybe ChainSync) -chainSyncingPeer = - chainSyncing <$> (readTVarIO =<< asks chainState) - --- | Get a block header from 'Chain' process. -chainGetBlock :: MonadIO m - => BlockHash -> Chain -> m (Maybe BlockNode) -chainGetBlock bh ch = - runReaderT (getBlockHeader bh) (myConfig (chainReader ch)) - --- | Get best block header from chain process. -chainGetBest :: MonadIO m => Chain -> m BlockNode -chainGetBest ch = - runReaderT getBestBlockHeader (myConfig (chainReader ch)) - --- | Get ancestor of 'BlockNode' at 'BlockHeight' from chain process. -chainGetAncestor :: MonadIO m - => BlockHeight - -> BlockNode - -> Chain - -> m (Maybe BlockNode) -chainGetAncestor h bn ch = - runReaderT (getAncestor h bn) (myConfig (chainReader ch)) - --- | Get parents of 'BlockNode' starting at 'BlockHeight' from chain process. -chainGetParents :: MonadIO m - => BlockHeight - -> BlockNode - -> Chain - -> m [BlockNode] -chainGetParents height top ch = - go [] top - where - go acc b - | height >= nodeHeight b = return acc - | otherwise = do - m <- chainGetBlock (prevBlock $ nodeHeader b) ch - case m of - Nothing -> return acc - Just p -> go (p : acc) p - --- | Get last common block from chain process. -chainGetSplitBlock :: MonadIO m - => BlockNode - -> BlockNode - -> Chain - -> m BlockNode -chainGetSplitBlock l r ch = - runReaderT (splitPoint l r) (myConfig (chainReader ch)) - --- | Notify chain that a new peer is connected. -chainPeerConnected :: MonadIO m - => Peer - -> Chain - -> m () -chainPeerConnected p ch = - ChainPeerConnected p `send` chainMailbox ch - --- | Notify chain that a peer has disconnected. -chainPeerDisconnected :: MonadIO m - => Peer - -> Chain - -> m () -chainPeerDisconnected p ch = - ChainPeerDisconnected p `send` chainMailbox ch - --- | Is given 'BlockHash' in the main chain? -chainBlockMain :: MonadIO m - => BlockHash - -> Chain - -> m Bool -chainBlockMain bh ch = - chainGetBest ch >>= \bb -> - chainGetBlock bh ch >>= \case - Nothing -> - return False - bm@(Just bn) -> - (== bm) <$> chainGetAncestor (nodeHeight bn) bb ch - --- | Is chain in sync with network? -chainIsSynced :: MonadIO m => Chain -> m Bool -chainIsSynced ch = - mySynced <$> readTVarIO (chainState (chainReader ch)) - --- | Peer sends a bunch of headers to the chain process. -chainHeaders :: MonadIO m - => Peer -> [BlockHeader] -> Chain -> m () -chainHeaders p hs ch = - ChainHeaders p hs `send` chainMailbox ch +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Haskoin.Node.Chain + ( ChainConfig (..), + ChainEvent (..), + Chain, + withChain, + chainGetBlock, + chainGetBest, + chainGetAncestor, + chainGetParents, + chainGetSplitBlock, + chainPeerConnected, + chainPeerDisconnected, + chainIsSynced, + chainBlockMain, + chainHeaders, + ) +where + +import Control.Monad (forM_, forever, guard, when) +import Control.Monad.Except (runExceptT, throwError) +import Control.Monad.Logger + ( MonadLoggerIO, + logDebugS, + logErrorS, + logInfoS, + ) +import Control.Monad.Reader + ( MonadReader, + ReaderT (..), + asks, + runReaderT, + ) +import Control.Monad.Trans (lift) +import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) +import qualified Data.ByteString as B +import Data.Function (on) +import Data.List (delete, nub) +import Data.Maybe (isJust, isNothing) +import Data.Serialize + ( Serialize, + get, + getWord8, + put, + putWord8, + ) +import Data.String.Conversions (cs) +import Data.Time.Clock + ( NominalDiffTime, + UTCTime, + diffUTCTime, + getCurrentTime, + ) +import Data.Time.Clock.POSIX + ( posixSecondsToUTCTime, + utcTimeToPOSIXSeconds, + ) +import Data.Word (Word32) +import Database.RocksDB (ColumnFamily, DB) +import qualified Database.RocksDB as R +import Database.RocksDB.Query + ( Key, + KeyValue, + insert, + insertCF, + insertOp, + insertOpCF, + retrieveCommon, + writeBatch, + ) +import Haskoin + ( BlockHash, + BlockHeader (..), + BlockHeaders (..), + BlockHeight, + BlockNode (..), + GetHeaders (..), + Message (..), + Network, + blockLocator, + connectBlocks, + genesisNode, + getAncestor, + headerHash, + splitPoint, + ) +import Haskoin.Node.Peer +import Haskoin.Node.PeerMgr (myVersion) +import NQE + ( Mailbox, + Publisher, + newMailbox, + publish, + receive, + send, + ) +import System.Random (randomRIO) +import UnliftIO + ( MonadIO, + MonadUnliftIO, + TVar, + atomically, + liftIO, + link, + modifyTVar, + newTVarIO, + readTVar, + readTVarIO, + withAsync, + writeTVar, + ) +import UnliftIO.Concurrent (threadDelay) + +-- | Mailbox for chain header syncing process. +data Chain = Chain + { mailbox :: !(Mailbox ChainMessage), + reader :: !ChainReader + } + +instance Eq Chain where + (==) = (==) `on` (.mailbox) + +-- | Configuration for chain syncing process. +data ChainConfig = ChainConfig + { -- | database handle + db :: !DB, + -- | column family + cf :: !(Maybe ColumnFamily), + -- | network constants + net :: !Network, + -- | send header chain events here + pub :: !(Publisher ChainEvent), + -- | timeout in seconds + timeout :: !NominalDiffTime + } + +data ChainMessage + = ChainHeaders !Peer ![BlockHeader] + | ChainPeerConnected !Peer + | ChainPeerDisconnected !Peer + | ChainPing + +-- | Events originating from chain syncing process. +data ChainEvent + = -- | chain has new best block + ChainBestBlock !BlockNode + | -- | chain is in sync with the network + ChainSynced !BlockNode + deriving (Eq, Show) + +type MonadChain m = + ( MonadLoggerIO m, + MonadUnliftIO m, + MonadReader ChainReader m + ) + +-- | State and configuration. +data ChainReader = ChainReader + { -- | placeholder for upstream data + config :: !ChainConfig, + -- | mutable state for header synchronization + state :: !(TVar ChainState) + } + +-- | Database key for version. +data ChainDataVersionKey = ChainDataVersionKey + deriving (Eq, Ord, Show) + +instance Key ChainDataVersionKey + +instance KeyValue ChainDataVersionKey Word32 + +instance Serialize ChainDataVersionKey where + get = do + guard . (== 0x92) =<< getWord8 + return ChainDataVersionKey + put ChainDataVersionKey = putWord8 0x92 + +data ChainSync = ChainSync + { peer :: !Peer, + timestamp :: !UTCTime, + best :: !(Maybe BlockNode) + } + +-- | Mutable state for the header chain process. +data ChainState = ChainState + { -- | peer to sync against and time of last received message + syncing :: !(Maybe ChainSync), + -- | queue of peers to sync against + peers :: ![Peer], + -- | has the header chain ever been considered synced? + beenInSync :: !Bool + } + +-- | Key for block header in database. +newtype BlockHeaderKey = BlockHeaderKey BlockHash deriving (Eq, Show) + +instance Serialize BlockHeaderKey where + get = do + guard . (== 0x90) =<< getWord8 + BlockHeaderKey <$> get + put (BlockHeaderKey bh) = do + putWord8 0x90 + put bh + +-- | Key for best block in database. +data BestBlockKey = BestBlockKey deriving (Eq, Show) + +instance KeyValue BlockHeaderKey BlockNode + +instance KeyValue BestBlockKey BlockNode + +instance Serialize BestBlockKey where + get = do + guard . (== 0x91) =<< getWord8 + return BestBlockKey + put BestBlockKey = putWord8 0x91 + +instance (MonadIO m) => BlockHeaders (ReaderT ChainConfig m) where + addBlockHeader bn = do + db <- asks (.db) + asks (.cf) >>= \case + Nothing -> insert db (BlockHeaderKey h) bn + Just cf -> insertCF db cf (BlockHeaderKey h) bn + where + h = headerHash bn.header + getBlockHeader bh = do + db <- asks (.db) + mcf <- asks (.cf) + retrieveCommon db mcf (BlockHeaderKey bh) + getBestBlockHeader = do + db <- asks (.db) + mcf <- asks (.cf) + retrieveCommon db mcf BestBlockKey >>= \case + Nothing -> error "Could not get best block from database" + Just b -> return b + setBestBlockHeader bn = do + db <- asks (.db) + asks (.cf) >>= \case + Nothing -> insert db BestBlockKey bn + Just cf -> insertCF db cf BestBlockKey bn + addBlockHeaders bns = do + db <- asks (.db) + mcf <- asks (.cf) + writeBatch db (map (f mcf) bns) + where + h bn = headerHash bn.header + f Nothing bn = insertOp (BlockHeaderKey (h bn)) bn + f (Just cf) bn = insertOpCF cf (BlockHeaderKey (h bn)) bn + +instance (MonadIO m) => BlockHeaders (ReaderT Chain m) where + getBlockHeader bh = ReaderT $ chainGetBlock bh + getBestBlockHeader = ReaderT chainGetBest + addBlockHeader _ = undefined + setBestBlockHeader _ = undefined + addBlockHeaders _ = undefined + +withBlockHeaders :: (MonadChain m) => ReaderT ChainConfig m a -> m a +withBlockHeaders f = do + cfg <- asks (.config) + runReaderT f cfg + +withChain :: + (MonadUnliftIO m, MonadLoggerIO m) => + ChainConfig -> + (Chain -> m a) -> + m a +withChain cfg action = do + (inbox, mailbox) <- newMailbox + $(logDebugS) "Chain" "Starting chain actor" + st <- + newTVarIO + ChainState + { syncing = Nothing, + beenInSync = False, + peers = [] + } + let rd = ChainReader {config = cfg, state = st} + ch = Chain {reader = rd, mailbox = mailbox} + runReaderT initChainDB rd + withAsync (main_loop ch rd inbox) $ \a -> + link a >> action ch + where + main_loop ch rd inbox = + withSyncLoop ch $ + runReaderT (run inbox) rd + run inbox = do + withBlockHeaders getBestBlockHeader + >>= chainEvent . ChainBestBlock + forever $ do + $(logDebugS) "Chain" "Awaiting event..." + msg <- receive inbox + chainMessage msg + +chainEvent :: (MonadChain m) => ChainEvent -> m () +chainEvent e = do + pub <- asks (.config.pub) + case e of + ChainBestBlock b -> + $(logInfoS) "Chain" $ + "Best block header at height: " + <> cs (show b.height) + ChainSynced b -> + $(logInfoS) "Chain" $ + "Headers in sync at height: " + <> cs (show b.height) + publish e pub + +processHeaders :: (MonadChain m) => Peer -> [BlockHeader] -> m () +processHeaders p hs = do + $(logDebugS) "Chain" $ + "Processing " + <> cs (show (length hs)) + <> " headers from peer: " + <> p.label + net <- asks (.config.net) + now <- liftIO getCurrentTime + pbest <- withBlockHeaders getBestBlockHeader + importHeaders net now hs >>= \case + Left e -> do + $(logErrorS) "Chain" $ + "Could not connect headers from peer: " + <> p.label + e `killPeer` p + Right done -> do + setLastReceived + best <- withBlockHeaders getBestBlockHeader + when (pbest.header /= best.header) $ + chainEvent (ChainBestBlock best) + if done + then do + MSendHeaders `sendMessage` p + finishPeer p + syncNewPeer + syncNotif + else syncPeer p + +syncNewPeer :: (MonadChain m) => m () +syncNewPeer = + getSyncingPeer >>= \case + Just _ -> return () + Nothing -> + nextPeer >>= \case + Nothing -> return () + Just p -> do + $(logDebugS) "Chain" $ + "Syncing against peer: " <> p.label + syncPeer p + +syncNotif :: (MonadChain m) => m () +syncNotif = + notifySynced >>= \case + False -> return () + True -> + withBlockHeaders getBestBlockHeader + >>= chainEvent . ChainSynced + +syncPeer :: (MonadChain m) => Peer -> m () +syncPeer p = do + t <- liftIO getCurrentTime + m <- + chainSyncingPeer >>= \case + Just + ChainSync + { peer = s, + best = m + } + | p == s -> syncing_me t m + | otherwise -> return Nothing + Nothing -> syncing_new t + forM_ m $ \g -> do + $(logDebugS) "Chain" $ + "Requesting headers from peer: " + <> p.label + MGetHeaders g `sendMessage` p + where + syncing_new t = + setSyncingPeer p >>= \case + False -> return Nothing + True -> do + $(logDebugS) "Chain" $ + "Locked peer: " <> p.label + h <- withBlockHeaders getBestBlockHeader + Just <$> syncHeaders t h p + syncing_me t m = do + h <- case m of + Nothing -> withBlockHeaders getBestBlockHeader + Just h -> return h + Just <$> syncHeaders t h p + +chainMessage :: (MonadChain m) => ChainMessage -> m () +chainMessage (ChainHeaders p hs) = + processHeaders p hs +chainMessage (ChainPeerConnected p) = do + $(logDebugS) "Chain" $ "Peer connected: " <> p.label + addPeer p + syncNewPeer +chainMessage (ChainPeerDisconnected p) = do + $(logDebugS) "Chain" $ "Peer disconnected: " <> p.label + finishPeer p + syncNewPeer +chainMessage ChainPing = do + $(logDebugS) "Chain" "Internal clock event" + to <- asks (.config.timeout) + now <- liftIO getCurrentTime + chainSyncingPeer >>= \case + Just ChainSync {peer = p, timestamp = t} + | now `diffUTCTime` t > to -> do + $(logErrorS) "Chain" $ + "Syncing peer timed out: " <> p.label + PeerTimeout `killPeer` p + | otherwise -> return () + Nothing -> syncNewPeer + +withSyncLoop :: + (MonadUnliftIO m, MonadLoggerIO m) => + Chain -> + m a -> + m a +withSyncLoop ch f = + withAsync go $ \a -> + link a >> f + where + go = forever $ do + delay <- + liftIO $ + randomRIO + ( 2 * 1000 * 1000, + 20 * 1000 * 1000 + ) + threadDelay delay + ChainPing `send` ch.mailbox + +-- | Version of the database. +dataVersion :: Word32 +dataVersion = 1 + +-- | Initialize header database. If version is different from current, the +-- database is purged of conflicting elements first. +initChainDB :: (MonadChain m) => m () +initChainDB = do + db <- asks (.config.db) + mcf <- asks (.config.cf) + net <- asks (.config.net) + ver <- retrieveCommon db mcf ChainDataVersionKey + when (ver /= Just dataVersion) $ purgeChainDB >>= writeBatch db + case mcf of + Nothing -> insert db ChainDataVersionKey dataVersion + Just cf -> insertCF db cf ChainDataVersionKey dataVersion + retrieveCommon db mcf BestBlockKey >>= \b -> + when (isNothing (b :: Maybe BlockNode)) $ + withBlockHeaders $ do + addBlockHeader (genesisNode net) + setBestBlockHeader (genesisNode net) + +-- | Purge database of elements having keys that may conflict with those used in +-- this module. +purgeChainDB :: (MonadChain m) => m [R.BatchOp] +purgeChainDB = do + db <- asks (.config.db) + mcf <- asks (.config.cf) + f db mcf $ \it -> do + R.iterSeek it $ B.singleton 0x90 + recurse_delete it db mcf + where + f db Nothing = R.withIter db + f db (Just cf) = R.withIterCF db cf + recurse_delete it db mcf = + R.iterKey it >>= \case + Just k + | B.head k == 0x90 || B.head k == 0x91 -> do + case mcf of + Nothing -> R.delete db k + Just cf -> R.deleteCF db cf k + R.iterNext it + (R.Del k :) <$> recurse_delete it db mcf + _ -> return [] + +-- | Import a bunch of continuous headers. Returns 'True' if the number of +-- headers is 2000, which means that there are possibly more headers to sync +-- from whatever peer delivered these. +importHeaders :: + (MonadChain m) => + Network -> + UTCTime -> + [BlockHeader] -> + m (Either PeerException Bool) +importHeaders net now hs = + runExceptT $ + lift connect >>= \case + Right _ -> do + case hs of + [] -> return () + _ -> do + bb <- lift get_last + box <- asks (.state) + atomically . modifyTVar box $ \s -> + s {syncing = (\x -> x {best = bb}) <$> s.syncing} + case length hs of + 2000 -> return False + _ -> return True + Left _ -> throwError PeerSentBadHeaders + where + timestamp = floor (utcTimeToPOSIXSeconds now) + connect = withBlockHeaders $ connectBlocks net timestamp hs + get_last = withBlockHeaders . getBlockHeader . headerHash $ last hs + +-- | Check if best block header is in sync with the rest of the block chain by +-- comparing the best block with the current time, verifying that there are no +-- peers in the queue to be synced, and no peer is being synced at the moment. +-- This function will only return 'True' once. It should be used to decide +-- whether to notify other processes that the header chain has been synced. The +-- state of the chain will be flipped to synced when this function returns +-- 'True'. +notifySynced :: (MonadChain m) => m Bool +notifySynced = + fmap isJust $ + runMaybeT $ do + bb <- lift $ withBlockHeaders getBestBlockHeader + now <- liftIO getCurrentTime + guard $ now `diffUTCTime` block_time bb > 7200 + st <- asks (.state) + MaybeT . atomically . runMaybeT $ do + s <- lift $ readTVar st + guard $ isNothing s.syncing + guard $ null s.peers + guard $ not s.beenInSync + lift $ writeTVar st s {beenInSync = True} + return () + where + block_time = + posixSecondsToUTCTime . fromIntegral . (.header.timestamp) + +-- | Get next peer to sync against from the queue. +nextPeer :: (MonadChain m) => m (Maybe Peer) +nextPeer = do + ps <- (.peers) <$> (readTVarIO =<< asks (.state)) + go ps + where + go [] = return Nothing + go (p : ps) = + setSyncingPeer p >>= \case + True -> return (Just p) + False -> go ps + +-- | Set a syncing peer and generate a 'GetHeaders' data structure with a block +-- locator to send to that peer for syncing. +syncHeaders :: + (MonadChain m) => + UTCTime -> + BlockNode -> + Peer -> + m GetHeaders +syncHeaders now bb p = do + st <- asks (.state) + atomically $ + modifyTVar st $ \s -> + s + { syncing = + Just + ChainSync + { peer = p, + timestamp = now, + best = Nothing + }, + peers = delete p s.peers + } + loc <- withBlockHeaders $ blockLocator bb + return + GetHeaders + { version = myVersion, + locator = loc, + stop = z + } + where + z = "0000000000000000000000000000000000000000000000000000000000000000" + +-- | Set the time of last received data to now if a syncing peer is active. +setLastReceived :: (MonadChain m) => m () +setLastReceived = do + now <- liftIO getCurrentTime + st <- asks (.state) + let f ChainSync {..} = ChainSync {timestamp = now, ..} + atomically . modifyTVar st $ \s -> + s {syncing = f <$> s.syncing} + +-- | Add a new peer to the queue of peers to sync against. +addPeer :: (MonadChain m) => Peer -> m () +addPeer p = do + st <- asks (.state) + atomically . modifyTVar st $ \s -> s {peers = nub (p : s.peers)} + +-- | Get syncing peer if there is one. +getSyncingPeer :: (MonadChain m) => m (Maybe Peer) +getSyncingPeer = + fmap (.peer) . (.syncing) + <$> (readTVarIO =<< asks (.state)) + +setSyncingPeer :: (MonadChain m) => Peer -> m Bool +setSyncingPeer p = + setBusy p >>= \case + False -> do + $(logDebugS) "Chain" $ + "Could not lock peer: " <> p.label + return False + True -> do + $(logDebugS) "Chain" $ + "Locked peer: " <> p.label + set_it + return True + where + set_it = do + now <- liftIO getCurrentTime + box <- asks (.state) + atomically $ modifyTVar box $ \s -> + s + { syncing = + Just + ChainSync + { peer = p, + timestamp = now, + best = Nothing + } + } + +-- | Remove a peer from the queue of peers to sync and unset the syncing peer if +-- it is set to the provided peer. +finishPeer :: (MonadChain m) => Peer -> m () +finishPeer p = + asks (.state) >>= remove_peer >>= \case + False -> + $(logDebugS) "Chain" $ + "Removed peer from queue: " <> p.label + True -> do + $(logDebugS) "Chain" $ + "Releasing syncing peer: " <> p.label + setFree p + where + remove_peer st = + atomically $ + readTVar st >>= \s -> case s.syncing of + Just ChainSync {peer = p'} + | p == p' -> do + unset_syncing st + return True + _ -> do + remove_from_queue st + return False + unset_syncing st = + modifyTVar st $ \x -> + x {syncing = Nothing} + remove_from_queue st = + modifyTVar st $ \x -> + x {peers = delete p x.peers} + +-- | Return syncing peer data. +chainSyncingPeer :: (MonadChain m) => m (Maybe ChainSync) +chainSyncingPeer = + (.syncing) <$> (readTVarIO =<< asks (.state)) + +-- | Get a block header from 'Chain' process. +chainGetBlock :: + (MonadIO m) => + BlockHash -> + Chain -> + m (Maybe BlockNode) +chainGetBlock bh ch = + runReaderT (getBlockHeader bh) (ch.reader.config) + +-- | Get best block header from chain process. +chainGetBest :: (MonadIO m) => Chain -> m BlockNode +chainGetBest ch = + runReaderT getBestBlockHeader ch.reader.config + +-- | Get ancestor of 'BlockNode' at 'BlockHeight' from chain process. +chainGetAncestor :: + (MonadIO m) => + BlockHeight -> + BlockNode -> + Chain -> + m (Maybe BlockNode) +chainGetAncestor h bn ch = + runReaderT (getAncestor h bn) ch.reader.config + +-- | Get parents of 'BlockNode' starting at 'BlockHeight' from chain process. +chainGetParents :: + (MonadIO m) => + BlockHeight -> + BlockNode -> + Chain -> + m [BlockNode] +chainGetParents height top ch = + go [] top + where + go acc b + | height >= b.height = return acc + | otherwise = do + m <- chainGetBlock b.header.prev ch + case m of + Nothing -> return acc + Just p -> go (p : acc) p + +-- | Get last common block from chain process. +chainGetSplitBlock :: + (MonadIO m) => + BlockNode -> + BlockNode -> + Chain -> + m BlockNode +chainGetSplitBlock l r ch = + runReaderT (splitPoint l r) ch.reader.config + +-- | Notify chain that a new peer is connected. +chainPeerConnected :: + (MonadIO m) => + Peer -> + Chain -> + m () +chainPeerConnected p ch = + ChainPeerConnected p `send` ch.mailbox + +-- | Notify chain that a peer has disconnected. +chainPeerDisconnected :: + (MonadIO m) => + Peer -> + Chain -> + m () +chainPeerDisconnected p ch = + ChainPeerDisconnected p `send` ch.mailbox + +-- | Is given 'BlockHash' in the main chain? +chainBlockMain :: + (MonadIO m) => + BlockHash -> + Chain -> + m Bool +chainBlockMain bh ch = + chainGetBest ch >>= \bb -> + chainGetBlock bh ch >>= \case + Nothing -> + return False + bm@(Just bn) -> + (== bm) <$> chainGetAncestor bn.height bb ch + +-- | Is chain in sync with network? +chainIsSynced :: (MonadIO m) => Chain -> m Bool +chainIsSynced ch = + (.beenInSync) <$> readTVarIO (ch.reader.state) + +-- | Peer sends a bunch of headers to the chain process. +chainHeaders :: + (MonadIO m) => + Peer -> + [BlockHeader] -> + Chain -> + m () +chainHeaders p hs ch = + ChainHeaders p hs `send` ch.mailbox diff --git a/src/Haskoin/Node/Manager.hs b/src/Haskoin/Node/Manager.hs deleted file mode 100644 --- a/src/Haskoin/Node/Manager.hs +++ /dev/null @@ -1,767 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} -module Haskoin.Node.Manager - ( PeerManagerConfig (..) - , PeerEvent (..) - , OnlinePeer (..) - , PeerManager - , withPeerManager - , managerBest - , managerVersion - , managerPing - , managerPong - , managerAddrs - , managerVerAck - , managerTickle - , getPeers - , getOnlinePeer - , buildVersion - , myVersion - , toSockAddr - , toHostService - ) where - -import Control.Arrow -import Control.Monad (forM_, forever, guard, void, when, - (<=<)) -import Control.Monad.Except (ExceptT (..), runExceptT, - throwError) -import Control.Monad.Logger (MonadLogger, MonadLoggerIO, - logDebugS, logErrorS, logInfoS, - logWarnS) -import Control.Monad.Reader (MonadReader, ReaderT (ReaderT), ask, - asks, runReaderT) -import Control.Monad.Trans (lift) -import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) -import Data.Bits ((.&.)) -import Data.Function (on) -import Data.List (find, nub, sort, dropWhileEnd, elemIndex) -import Data.Maybe (fromMaybe, isJust) -import Data.Set (Set) -import qualified Data.Set as Set -import Data.String.Conversions (cs) -import Data.Time.Clock (NominalDiffTime, UTCTime, - addUTCTime, diffUTCTime, - getCurrentTime) -import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) -import Data.Word (Word32, Word64) -import Haskoin (BlockHeight, Message (..), - Network (..), NetworkAddress (..), - Ping (..), Pong (..), - VarString (..), Version (..), - hostToSockAddr, nodeNetwork, - sockToHostAddress) -import Haskoin.Node.Peer -import NQE (Child, Inbox, Mailbox, Publisher, - Strategy (..), Supervisor, addChild, - inboxToMailbox, newInbox, - newMailbox, publish, receive, - receiveMatch, send, sendSTM, - withSupervisor) -import Network.Socket (AddrInfo (..), AddrInfoFlag (..), - Family (..), SockAddr (..), - SocketType (..), defaultHints, - getAddrInfo) -import System.Random (randomIO, randomRIO) -import UnliftIO (Async, MonadIO, MonadUnliftIO, STM, - SomeException, TVar, atomically, - catch, liftIO, link, modifyTVar, - newTVarIO, readTVar, readTVarIO, - withAsync, withRunInIO, writeTVar) -import UnliftIO.Concurrent (threadDelay) -import Control.Applicative ((<|>)) - -type MonadManager m = (MonadIO m, MonadReader PeerManager m) - -data PeerEvent - = PeerConnected !Peer - | PeerDisconnected !Peer - deriving Eq - -data PeerManagerConfig = - PeerManagerConfig - { peerManagerMaxPeers :: !Int - , peerManagerPeers :: ![String] - , peerManagerDiscover :: !Bool - , peerManagerNetAddr :: !NetworkAddress - , peerManagerNetwork :: !Network - , peerManagerEvents :: !(Publisher PeerEvent) - , peerManagerTimeout :: !NominalDiffTime - , peerManagerMaxLife :: !NominalDiffTime - , peerManagerConnect :: !(SockAddr -> WithConnection) - , peerManagerPub :: !(Publisher (Peer, Message)) - } - -data PeerManager = - PeerManager - { myConfig :: !PeerManagerConfig - , mySupervisor :: !Supervisor - , myMailbox :: !(Mailbox ManagerMessage) - , myBestBlock :: !(TVar BlockHeight) - , knownPeers :: !(TVar (Set SockAddr)) - , onlinePeers :: !(TVar [OnlinePeer]) - } - -data ManagerMessage - = Connect !SockAddr - | CheckPeer !Peer - | PeerDied !Child !(Maybe SomeException) - | ManagerBest !BlockHeight - | PeerVerAck !Peer - | PeerVersion !Peer !Version - | PeerPing !Peer !Word64 - | PeerPong !Peer !Word64 - | PeerAddrs !Peer ![NetworkAddress] - | PeerTickle !Peer - --- | Data structure representing an online peer. -data OnlinePeer = - OnlinePeer - { onlinePeerAddress :: !SockAddr - , onlinePeerVerAck :: !Bool - , onlinePeerConnected :: !Bool - , onlinePeerVersion :: !(Maybe Version) - , onlinePeerAsync :: !(Async ()) - , onlinePeerMailbox :: !Peer - , onlinePeerNonce :: !Word64 - , onlinePeerPing :: !(Maybe (UTCTime, Word64)) - , onlinePeerPings :: ![NominalDiffTime] - , onlinePeerConnectTime :: !UTCTime - , onlinePeerTickled :: !UTCTime - , onlinePeerDisconnect :: !UTCTime - } - -instance Eq OnlinePeer where - (==) = (==) `on` f - where - f OnlinePeer {onlinePeerMailbox = p} = p - -instance Ord OnlinePeer where - compare = compare `on` f - where - f OnlinePeer {onlinePeerPings = pings} = fromMaybe 60 (median pings) - -withPeerManager :: (MonadUnliftIO m, MonadLoggerIO m) - => PeerManagerConfig - -> (PeerManager -> m a) - -> m a -withPeerManager cfg action = do - inbox <- newInbox - let mgr = inboxToMailbox inbox - withSupervisor (Notify (death mgr)) $ \sup -> do - bb <- newTVarIO 0 - kp <- newTVarIO Set.empty - ob <- newTVarIO [] - let rd = PeerManager { myConfig = cfg - , mySupervisor = sup - , myMailbox = mgr - , myBestBlock = bb - , knownPeers = kp - , onlinePeers = ob - } - go inbox `runReaderT` rd - where - death mgr (a, ex) = PeerDied a ex `sendSTM` mgr - go inbox = - withAsync (peerManager inbox) $ \a -> - withConnectLoop $ - link a >> ReaderT action - -peerManager :: ( MonadUnliftIO m - , MonadManager m - , MonadLoggerIO m ) - => Inbox ManagerMessage - -> m () -peerManager inb = do - $(logDebugS) "PeerManager" "Awaiting best block" - putBestBlock <=< receiveMatch inb $ \case - ManagerBest b -> Just b - _ -> Nothing - $(logDebugS) "PeerManager" "Starting peer manager actor" - forever loop - where - loop = do - m <- receive inb - managerMessage m - -putBestBlock :: MonadManager m => BlockHeight -> m () -putBestBlock bb = do - b <- asks myBestBlock - atomically $ writeTVar b bb - -getBestBlock :: MonadManager m => m BlockHeight -getBestBlock = - asks myBestBlock >>= readTVarIO - -getNetwork :: MonadManager m => m Network -getNetwork = - asks (peerManagerNetwork . myConfig) - -loadPeers :: (MonadUnliftIO m, MonadManager m) => m () -loadPeers = do - loadStaticPeers - loadNetSeeds - -loadStaticPeers :: (MonadUnliftIO m, MonadManager m) => m () -loadStaticPeers = do - net <- asks (peerManagerNetwork . myConfig) - xs <- asks (peerManagerPeers . myConfig) - mapM_ newPeer . concat =<< mapM (toSockAddr net) xs - -loadNetSeeds :: (MonadUnliftIO m, MonadManager m) => m () -loadNetSeeds = - asks (peerManagerDiscover . myConfig) >>= \discover -> - when discover $ do - net <- getNetwork - ss <- concat <$> mapM (toSockAddr net) (getSeeds net) - mapM_ newPeer ss - -logConnectedPeers :: (MonadManager m, MonadLoggerIO m) => m () -logConnectedPeers = do - m <- asks (peerManagerMaxPeers . myConfig) - l <- length <$> getConnectedPeers - $(logInfoS) "PeerManager" $ - "Peers connected: " <> cs (show l) <> "/" <> cs (show m) - -getOnlinePeers :: MonadManager m => m [OnlinePeer] -getOnlinePeers = - asks onlinePeers >>= readTVarIO - -getConnectedPeers :: MonadManager m => m [OnlinePeer] -getConnectedPeers = - filter onlinePeerConnected <$> getOnlinePeers - -managerEvent :: MonadManager m => PeerEvent -> m () -managerEvent e = - publish e =<< asks (peerManagerEvents . myConfig) - -managerMessage :: ( MonadUnliftIO m - , MonadManager m - , MonadLoggerIO m ) - => ManagerMessage - -> m () - -managerMessage (PeerVersion p v) = do - b <- asks onlinePeers - e <- runExceptT $ do - o <- ExceptT . atomically $ setPeerVersion b p v - when (onlinePeerConnected o) $ announcePeer p - case e of - Right () -> do - $(logDebugS) "PeerManager" $ - "Sending version ack to peer: " <> peerText p - MVerAck `sendMessage` p - Left x -> do - $(logErrorS) "PeerManager" $ - "Version rejected for peer " - <> peerText p <> ": " <> cs (show x) - killPeer x p - -managerMessage (PeerVerAck p) = do - b <- asks onlinePeers - atomically (setPeerVerAck b p) >>= \case - Just o -> do - $(logDebugS) "PeerManager" $ - "Received version ack from peer: " - <> peerText p - when (onlinePeerConnected o) $ - announcePeer p - Nothing -> do - $(logErrorS) "PeerManager" $ - "Received verack from unknown peer: " - <> peerText p - killPeer UnknownPeer p - -managerMessage (PeerAddrs p nas) = do - discover <- asks (peerManagerDiscover . myConfig) - when discover $ do - let sas = map (hostToSockAddr . naAddress) nas - forM_ (zip [(1 :: Int) ..] sas) $ \(i, a) -> do - $(logDebugS) "PeerManager" $ - "Got peer address " - <> cs (show i) <> "/" <> cs (show (length sas)) - <> ": " <> cs (show a) - <> " from peer " <> peerText p - newPeer a - -managerMessage (PeerPong p n) = do - b <- asks onlinePeers - $(logDebugS) "PeerManager" $ - "Received pong " - <> cs (show n) - <> " from: " <> peerText p - now <- liftIO getCurrentTime - atomically (gotPong b n now p) - -managerMessage (PeerPing p n) = do - $(logDebugS) "PeerManager" $ - "Responding to ping " - <> cs (show n) - <> " from: " <> peerText p - MPong (Pong n) `sendMessage` p - -managerMessage (ManagerBest h) = - putBestBlock h - -managerMessage (Connect sa) = - connectPeer sa - -managerMessage (PeerDied a e) = - processPeerOffline a e - -managerMessage (CheckPeer p) = - checkPeer p - -managerMessage (PeerTickle p) = do - b <- asks onlinePeers - now <- liftIO getCurrentTime - atomically $ - modifyPeer b p $ \o -> - o { onlinePeerTickled = now } - -checkPeer :: (MonadManager m, MonadLoggerIO m) => Peer -> m () -checkPeer p = - getBusy p >>= \case - True -> return () - False -> do - to <- asks (peerManagerTimeout . myConfig) - b <- asks onlinePeers - atomically (findPeer b p) >>= \case - Nothing -> return () - Just o -> do - now <- liftIO getCurrentTime - check_conn now o - when (check_tickle now to o) (check_ping o) - where - check_tickle now to o = - now `diffUTCTime` onlinePeerTickled o > to - check_conn now o = - when (now `diffUTCTime` onlinePeerDisconnect o > 0) $ - killPeer PeerTooOld p - check_ping o = - case onlinePeerPing o of - Nothing -> - sendPing p - Just _ -> do - $(logWarnS) "PeerManager" $ - "Peer ping timeout: " <> peerText p - killPeer PeerTimeout p - -sendPing :: (MonadManager m, MonadLoggerIO m) => Peer -> m () -sendPing p = do - b <- asks onlinePeers - atomically (findPeer b p) >>= \case - Nothing -> - $(logWarnS) "PeerManager" $ - "Will not ping unknown peer: " <> peerText p - Just o - | onlinePeerConnected o -> do - n <- liftIO randomIO - now <- liftIO getCurrentTime - atomically (setPeerPing b n now p) - $(logDebugS)" PeerManager" $ - "Sending ping " <> cs (show n) - <> " to: " <> peerText p - MPing (Ping n) `sendMessage` p - | otherwise -> return () - -processPeerOffline :: (MonadManager m, MonadLoggerIO m) - => Child -> Maybe SomeException -> m () -processPeerOffline a e = do - b <- asks onlinePeers - atomically (findPeerAsync b a) >>= \case - Nothing -> log_unknown e - Just o -> do - let p = onlinePeerMailbox o - if onlinePeerConnected o - then do - log_disconnected p e - managerEvent $ PeerDisconnected p - else log_not_connect p e - atomically $ removePeer b p - logConnectedPeers - where - log_unknown Nothing = - $(logErrorS) "PeerManager" - "Disconnected unknown peer" - log_unknown (Just x) = - $(logErrorS) "PeerManager" $ - "Unknown peer died: " <> cs (show x) - log_disconnected p Nothing = - $(logWarnS) "PeerManager" $ - "Disconnected peer: " <> peerText p - log_disconnected p (Just x) = - $(logErrorS) "PeerManager" $ - "Peer " <> peerText p <> " died: " <> cs (show x) - log_not_connect p Nothing = - $(logWarnS) "PeerManager" $ - "Could not connect to peer " <> peerText p - log_not_connect p (Just x) = - $(logErrorS) "PeerManager" $ - "Could not connect to peer " - <> peerText p <> ": " <> cs (show x) - -announcePeer :: (MonadManager m, MonadLoggerIO m) => Peer -> m () -announcePeer p = do - b <- asks onlinePeers - atomically (findPeer b p) >>= \case - Just OnlinePeer {onlinePeerConnected = True} -> do - $(logInfoS) "PeerManager" $ - "Connected to peer " <> peerText p - managerEvent $ PeerConnected p - logConnectedPeers - Just OnlinePeer {onlinePeerConnected = False} -> - return () - Nothing -> - $(logErrorS) "PeerManager" $ - "Not announcing disconnected peer: " - <> peerText p - -getNewPeer :: (MonadUnliftIO m, MonadManager m) => m (Maybe SockAddr) -getNewPeer = - runMaybeT $ lift loadPeers >> go - where - go = do - b <- asks knownPeers - ks <- readTVarIO b - guard . not $ Set.null ks - let xs = Set.toList ks - a <- liftIO $ randomRIO (0, length xs - 1) - let p = xs !! a - o <- asks onlinePeers - m <- atomically $ do - modifyTVar b $ Set.delete p - findPeerAddress o p - maybe (return p) (const go) m - - -connectPeer :: ( MonadUnliftIO m - , MonadManager m - , MonadLoggerIO m - ) - => SockAddr - -> m () -connectPeer sa = do - os <- asks onlinePeers - atomically (findPeerAddress os sa) >>= \case - Just _ -> - $(logErrorS) "PeerManager" $ - "Attempted to connect to peer twice: " <> cs (show sa) - Nothing -> do - $(logInfoS) "PeerManager" $ "Connecting to " <> cs (show sa) - PeerManagerConfig { peerManagerNetAddr = ad - , peerManagerNetwork = net - } <- asks myConfig - sup <- asks mySupervisor - conn <- asks (peerManagerConnect . myConfig) - pub <- asks (peerManagerPub . myConfig) - nonce <- liftIO randomIO - bb <- getBestBlock - now <- liftIO getCurrentTime - let rmt = NetworkAddress (srv net) (sockToHostAddress sa) - unix = floor (utcTimeToPOSIXSeconds now) - ver = buildVersion net nonce bb ad rmt unix - text = cs (show sa) - (inbox, mailbox) <- newMailbox - let pc = PeerConfig { peerConfPub = pub - , peerConfNetwork = net - , peerConfText = text - , peerConfConnect = conn sa - } - busy <- newTVarIO False - p <- wrapPeer pc busy mailbox - a <- withRunInIO $ \io -> - sup `addChild` io (launch pc busy inbox p) - MVersion ver `sendMessage` p - b <- asks onlinePeers - max_life <- asks (peerManagerMaxLife . myConfig) - rand <- liftIO $ toRational <$> randomRIO (0.75 :: Double, 1.00) - let life = max_life * fromRational rand - let dc = life `addUTCTime` now - _ <- atomically $ newOnlinePeer b sa nonce p a now dc - return () - where - srv net - | getSegWit net = 8 - | otherwise = 0 - launch pc busy inbox p = - ask >>= \mgr -> - withPeerLoop sa p mgr $ \a -> - link a >> peer pc busy inbox - -withPeerLoop :: - (MonadUnliftIO m, MonadLogger m) - => SockAddr - -> Peer - -> PeerManager - -> (Async a -> m a) - -> m a -withPeerLoop _ p mgr = - withAsync . forever $ do - let x = peerManagerTimeout (myConfig mgr) - y = floor (x * 1000000) - r <- liftIO $ randomRIO (y * 3 `div` 4, y) - threadDelay r - managerCheck p mgr - -withConnectLoop :: (MonadUnliftIO m, MonadManager m) - => m a - -> m a -withConnectLoop act = - withAsync go $ \a -> - link a >> act - where - go = forever $ do - l <- length <$> getOnlinePeers - x <- asks (peerManagerMaxPeers . myConfig) - when (l < x) $ - getNewPeer >>= mapM_ (\sa -> ask >>= managerConnect sa) - delay <- liftIO $ - randomRIO ( 100 * 1000 - , 10 * 500 * 1000 ) - threadDelay delay - -newPeer :: (MonadIO m, MonadManager m) => SockAddr -> m () -newPeer sa = do - b <- asks knownPeers - o <- asks onlinePeers - atomically $ - findPeerAddress o sa >>= \case - Just _ -> return () - Nothing -> modifyTVar b $ Set.insert sa - -gotPong :: TVar [OnlinePeer] -> Word64 -> UTCTime -> Peer -> STM () -gotPong b nonce now p = void . runMaybeT $ do - o <- MaybeT $ findPeer b p - (time, old_nonce) <- MaybeT . return $ onlinePeerPing o - guard $ nonce == old_nonce - let diff = now `diffUTCTime` time - lift $ - insertPeer - b - o { onlinePeerPing = Nothing - , onlinePeerPings = sort $ take 11 $ diff : onlinePeerPings o - } - -setPeerPing :: TVar [OnlinePeer] -> Word64 -> UTCTime -> Peer -> STM () -setPeerPing b nonce now p = - modifyPeer b p $ \o -> o {onlinePeerPing = Just (now, nonce)} - -setPeerVersion :: - TVar [OnlinePeer] - -> Peer - -> Version - -> STM (Either PeerException OnlinePeer) -setPeerVersion b p v = runExceptT $ do - when (services v .&. nodeNetwork == 0) $ - throwError NotNetworkPeer - ops <- lift $ readTVar b - when (any ((verNonce v ==) . onlinePeerNonce) ops) $ - throwError PeerIsMyself - lift (findPeer b p) >>= \case - Nothing -> throwError UnknownPeer - Just o -> do - let n = o { onlinePeerVersion = Just v - , onlinePeerConnected = onlinePeerVerAck o } - lift $ insertPeer b n - return n - -setPeerVerAck :: TVar [OnlinePeer] -> Peer -> STM (Maybe OnlinePeer) -setPeerVerAck b p = runMaybeT $ do - o <- MaybeT $ findPeer b p - let n = o { onlinePeerVerAck = True - , onlinePeerConnected = isJust (onlinePeerVersion o) } - lift $ insertPeer b n - return n - -newOnlinePeer :: - TVar [OnlinePeer] - -> SockAddr - -> Word64 - -> Peer - -> Async () - -> UTCTime - -> UTCTime - -> STM OnlinePeer -newOnlinePeer box addr nonce p peer_async connect_time dc = do - let op = OnlinePeer - { onlinePeerAddress = addr - , onlinePeerVerAck = False - , onlinePeerConnected = False - , onlinePeerVersion = Nothing - , onlinePeerAsync = peer_async - , onlinePeerMailbox = p - , onlinePeerNonce = nonce - , onlinePeerPings = [] - , onlinePeerPing = Nothing - , onlinePeerConnectTime = connect_time - , onlinePeerTickled = connect_time - , onlinePeerDisconnect = dc - } - insertPeer box op - return op - -findPeer :: TVar [OnlinePeer] -> Peer -> STM (Maybe OnlinePeer) -findPeer b p = - find ((== p) . onlinePeerMailbox) - <$> readTVar b - -insertPeer :: TVar [OnlinePeer] -> OnlinePeer -> STM () -insertPeer b o = - modifyTVar b $ \x -> sort . nub $ o : x - -modifyPeer :: TVar [OnlinePeer] - -> Peer - -> (OnlinePeer -> OnlinePeer) - -> STM () -modifyPeer b p f = - findPeer b p >>= \case - Nothing -> return () - Just o -> insertPeer b $ f o - -removePeer :: TVar [OnlinePeer] -> Peer -> STM () -removePeer b p = - modifyTVar b $ - filter ((/= p) . onlinePeerMailbox) - -findPeerAsync :: TVar [OnlinePeer] - -> Async () - -> STM (Maybe OnlinePeer) -findPeerAsync b a = - find ((== a) . onlinePeerAsync) - <$> readTVar b - -findPeerAddress :: TVar [OnlinePeer] - -> SockAddr - -> STM (Maybe OnlinePeer) -findPeerAddress b a = - find ((== a) . onlinePeerAddress) - <$> readTVar b - -getPeers :: MonadIO m => PeerManager -> m [OnlinePeer] -getPeers = runReaderT getConnectedPeers - -getOnlinePeer :: MonadIO m - => Peer - -> PeerManager - -> m (Maybe OnlinePeer) -getOnlinePeer p = - runReaderT $ asks onlinePeers >>= atomically . (`findPeer` p) - -managerCheck :: MonadIO m => Peer -> PeerManager -> m () -managerCheck p mgr = - CheckPeer p `send` myMailbox mgr - -managerConnect :: MonadIO m => SockAddr -> PeerManager -> m () -managerConnect sa mgr = - Connect sa `send` myMailbox mgr - -managerBest :: MonadIO m => BlockHeight -> PeerManager -> m () -managerBest bh mgr = - ManagerBest bh `send` myMailbox mgr - -managerVerAck :: MonadIO m => Peer -> PeerManager -> m () -managerVerAck p mgr = - PeerVerAck p `send` myMailbox mgr - -managerVersion :: MonadIO m - => Peer -> Version -> PeerManager -> m () -managerVersion p ver mgr = - PeerVersion p ver `send` myMailbox mgr - -managerPing :: MonadIO m - => Peer -> Word64 -> PeerManager -> m () -managerPing p nonce mgr = - PeerPing p nonce `send` myMailbox mgr - -managerPong :: MonadIO m - => Peer -> Word64 -> PeerManager -> m () -managerPong p nonce mgr = - PeerPong p nonce `send` myMailbox mgr - -managerAddrs :: MonadIO m - => Peer -> [NetworkAddress] -> PeerManager -> m () -managerAddrs p addrs mgr = - PeerAddrs p addrs `send` myMailbox mgr - -managerTickle :: MonadIO m - => Peer -> PeerManager -> m () -managerTickle p mgr = - PeerTickle p `send` myMailbox mgr - -toHostService :: String -> (Maybe String, Maybe String) -toHostService str = - let host = case m6 of - Just (x, _) -> Just x - Nothing -> case takeWhile (/= ':') str of - [] -> Nothing - xs -> Just xs - srv = case m6 of - Just (_, y) -> s y - Nothing -> s str - s xs = - case dropWhile (/= ':') xs of - [] -> Nothing - _ : ys -> Just ys - m6 = case str of - (x : xs) - | x == '[' -> do - i <- elemIndex ']' xs - return $ second tail $ splitAt i xs - | x == ':' -> do - return (str, "") - _ -> Nothing - in (host, srv) - -toSockAddr :: MonadUnliftIO m => Network -> String -> m [SockAddr] -toSockAddr net str = - go `catch` e - where - go = fmap (map addrAddress) $ liftIO $ getAddrInfo Nothing host srv - (host, srv) = - second (<|> Just (show (getDefaultPort net))) $ - toHostService str - e :: Monad m => SomeException -> m [SockAddr] - e _ = return [] - -median :: (Ord a, Fractional a) => [a] -> Maybe a -median ls - | null ls = - Nothing - | even (length ls) = - Just . (/ 2) . sum . take 2 $ - drop (length ls `div` 2 - 1) ls' - | otherwise = - Just (ls' !! (length ls `div` 2)) - where - ls' = sort ls - -buildVersion - :: Network - -> Word64 - -> BlockHeight - -> NetworkAddress - -> NetworkAddress - -> Word64 - -> Version -buildVersion net nonce height loc rmt time = - Version - { version = myVersion - , services = naServices loc - , timestamp = time - , addrRecv = rmt - , addrSend = loc - , verNonce = nonce - , userAgent = VarString (getHaskoinUserAgent net) - , startHeight = height - , relay = True - } - -myVersion :: Word32 -myVersion = 70012 diff --git a/src/Haskoin/Node/Peer.hs b/src/Haskoin/Node/Peer.hs --- a/src/Haskoin/Node/Peer.hs +++ b/src/Haskoin/Node/Peer.hs @@ -1,328 +1,405 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE NoFieldSelectors #-} + module Haskoin.Node.Peer - ( PeerConfig(..) - , Conduits(..) - , PeerException(..) - , WithConnection - , Peer - , peer - , wrapPeer - , peerPublisher - , peerText - , sendMessage - , killPeer - , getBlocks - , getTxs - , getData - , pingPeer - , getBusy - , setBusy - , setFree - ) where + ( PeerConfig (..), + PeerEvent (..), + Conduits (..), + PeerException (..), + WithConnection, + Peer (..), + peer, + wrapPeer, + sendMessage, + killPeer, + getBlocks, + getTxs, + getData, + pingPeer, + getBusy, + setBusy, + setFree, + ) +where -import Conduit (ConduitT, Void, awaitForever, foldC, - mapM_C, runConduit, takeCE, - transPipe, yield, (.|)) -import Control.Monad (forever, join, when) -import Control.Monad.Logger (MonadLoggerIO, logErrorS) -import Control.Monad.Trans.Maybe (MaybeT (MaybeT), runMaybeT) -import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import Data.Function (on) -import Data.List (union) -import Data.Maybe (isJust) -import Data.Serialize (decode, runGet, runPut) -import Data.String.Conversions (cs) -import Data.Text (Text) -import Data.Word (Word32) -import Haskoin (Block (..), BlockHash (..), - GetData (..), InvType (..), - InvVector (..), Message (..), - MessageCommand (..), - MessageHeader (..), Network (..), - NotFound (..), Ping (..), Pong (..), - Tx, TxHash (..), commandToString, - encodeHex, getMessage, headerHash, - putMessage, txHash) -import NQE (Inbox, Mailbox, Publisher, - inboxToMailbox, publish, receive, - receiveMatchS, send, - withSubscription) -import System.Random (randomIO) -import UnliftIO (Exception, MonadIO, MonadUnliftIO, - TVar, atomically, liftIO, link, - readTVar, readTVarIO, throwIO, - timeout, withAsync, withRunInIO, - writeTVar) +import Conduit + ( ConduitT, + Void, + awaitForever, + foldC, + mapM_C, + runConduit, + takeCE, + transPipe, + yield, + (.|), + ) +import Control.Monad (forever, join, unless, when) +import Control.Monad.Logger (MonadLoggerIO, logDebugS, logErrorS, logInfoS) +import Control.Monad.Trans.Maybe (MaybeT (MaybeT), runMaybeT) +import Data.Bool (bool) +import Data.ByteString (ByteString) +import Data.ByteString qualified as B +import Data.Function (on) +import Data.List (union) +import Data.Maybe (isJust) +import Data.Serialize (decode, runGet, runPut) +import Data.String.Conversions (cs) +import Data.Text (Text) +import Data.Word (Word32) +import Haskoin + ( Block (..), + BlockHash (..), + GetData (..), + InvType (..), + InvVector (..), + Message (..), + MessageCommand (..), + MessageHeader (..), + Network (..), + NotFound (..), + Ping (..), + Pong (..), + Tx, + TxHash (..), + commandToString, + encodeHex, + getMessage, + headerHash, + putMessage, + txHash, + ) +import NQE + ( Inbox, + Mailbox, + Publisher, + inboxToMailbox, + publish, + receive, + receiveMatchS, + send, + withSubscription, + ) +import System.Random (randomIO) +import UnliftIO + ( Exception, + MonadIO, + MonadUnliftIO, + TVar, + atomically, + liftIO, + link, + readTVar, + readTVarIO, + throwIO, + timeout, + withAsync, + withRunInIO, + writeTVar, + ) -data Conduits = - Conduits - { inboundConduit :: ConduitT () ByteString IO () - , outboundConduit :: ConduitT ByteString Void IO () - } +data Conduits = Conduits + { inboundConduit :: ConduitT () ByteString IO (), + outboundConduit :: ConduitT ByteString Void IO () + } type WithConnection = (Conduits -> IO ()) -> IO () data PeerConfig = PeerConfig - { peerConfPub :: !(Publisher (Peer, Message)) - , peerConfNetwork :: !Network - , peerConfText :: !Text - , peerConfConnect :: !WithConnection - } + { pub :: !(Publisher PeerEvent), + net :: !Network, + label :: !Text, + connect :: !WithConnection + } +data PeerEvent + = PeerConnected !Peer + | PeerDisconnected !Peer + | PeerMessage !Peer !Message + deriving (Eq) + data PeerException - = PeerMisbehaving !String - | DuplicateVersion - | DecodeHeaderError - | CannotDecodePayload !MessageCommand - | PeerIsMyself - | PayloadTooLarge !Word32 - | PeerAddressInvalid - | PeerSentBadHeaders - | NotNetworkPeer - | PeerNoSegWit - | PeerTimeout - | UnknownPeer - | PeerTooOld - | EmptyHeader - deriving Eq + = PeerMisbehaving !String + | DuplicateVersion + | DecodeHeaderError + | CannotDecodePayload !MessageCommand + | PeerIsMyself + | PayloadTooLarge !Word32 + | PeerAddressInvalid + | PeerSentBadHeaders + | NotNetworkPeer + | PeerNoSegWit + | PeerTimeout + | UnknownPeer + | PeerTooOld + | EmptyHeader + deriving (Eq) instance Show PeerException where - show (PeerMisbehaving s) = "Peer misbehaving: " <> s - show DuplicateVersion = "Duplicate version" - show DecodeHeaderError = "Error decoding header" - show (CannotDecodePayload c) = "Cannot decode payload: " <> - cs (commandToString c) - show PeerIsMyself = "Peer is myself" - show (PayloadTooLarge s) = "Payload too large: " <> show s - show PeerAddressInvalid = "Peer address invalid" - show PeerSentBadHeaders = "Peer sent bad headers" - show NotNetworkPeer = "Not network peer" - show PeerNoSegWit = "Segwit not supported by peer" - show PeerTimeout = "Peer timed out" - show UnknownPeer = "Unknown peer" - show PeerTooOld = "Peer too old" - show EmptyHeader = "Empty header" + show (PeerMisbehaving s) = "Peer misbehaving: " <> s + show DuplicateVersion = "Duplicate version" + show DecodeHeaderError = "Error decoding header" + show (CannotDecodePayload c) = + "Cannot decode payload: " + <> cs (commandToString c) + show PeerIsMyself = "Peer is myself" + show (PayloadTooLarge s) = "Payload too large: " <> show s + show PeerAddressInvalid = "Peer address invalid" + show PeerSentBadHeaders = "Peer sent bad headers" + show NotNetworkPeer = "Not network peer" + show PeerNoSegWit = "Segwit not supported by peer" + show PeerTimeout = "Peer timed out" + show UnknownPeer = "Unknown peer" + show PeerTooOld = "Peer too old" + show EmptyHeader = "Empty header" instance Exception PeerException -- | Mailbox for a peer. -data Peer = Peer { peerMailbox :: !(Mailbox PeerMessage) - , peerPublisher :: !(Publisher (Peer, Message)) - , peerText :: !Text - , peerBusy :: !(TVar Bool) - } +data Peer = Peer + { mailbox :: !(Mailbox PeerMessage), + pub :: !(Publisher PeerEvent), + label :: !Text, + busy :: !(TVar Bool) + } instance Eq Peer where - (==) = (==) `on` peerMailbox + (==) = (==) `on` (.mailbox) instance Show Peer where - show = cs . peerText + show = cs . (.label) -- | Incoming messages that a peer accepts. data PeerMessage - = KillPeer !PeerException - | SendMessage !Message + = KillPeer !PeerException + | SendMessage !Message -wrapPeer :: MonadIO m - => PeerConfig - -> TVar Bool - -> Mailbox PeerMessage - -> m Peer +wrapPeer :: + (MonadIO m) => + PeerConfig -> + TVar Bool -> + Mailbox PeerMessage -> + m Peer wrapPeer cfg busy mbox = - return Peer { peerMailbox = mbox - , peerPublisher = peerConfPub cfg - , peerText = peerConfText cfg - , peerBusy = busy - } + return + Peer + { mailbox = mbox, + pub = cfg.pub, + label = cfg.label, + busy = busy + } -- | Run peer process in current thread. -peer :: (MonadUnliftIO m, MonadLoggerIO m) - => PeerConfig - -> TVar Bool - -> Inbox PeerMessage - -> m () -peer cfg@PeerConfig{..} busy inbox = do - p <- wrapPeer cfg busy (inboxToMailbox inbox) - withRunInIO $ \restore -> do - peerConfConnect (peer_session p) +peer :: + (MonadUnliftIO m, MonadLoggerIO m) => + PeerConfig -> + TVar Bool -> + Inbox PeerMessage -> + m () +peer cfg@PeerConfig {..} busy inbox = do + p <- wrapPeer cfg busy (inboxToMailbox inbox) + withRunInIO $ \restore -> do + connect (restore . peer_session p) where - go = forever $ receive inbox >>= dispatchMessage cfg + go = forever $ do + $(logDebugS) "Peer" $ label <> " awaiting event..." + msg <- receive inbox + dispatchMessage cfg msg peer_session p ad = do - let ins = transPipe liftIO (inboundConduit ad) - ons = transPipe liftIO (outboundConduit ad) - src = runConduit $ - ins - .| inPeerConduit peerConfNetwork peerConfText + let ins = transPipe liftIO ad.inboundConduit + ons = transPipe liftIO ad.outboundConduit + src = + runConduit $ + ins + .| inPeerConduit net cfg label .| mapM_C (send_msg p) - snk = outPeerConduit peerConfNetwork .| ons - withAsync src $ \as -> do - link as - runConduit (go .| snk) - send_msg p msg = publish (p, msg) peerConfPub + snk = outPeerConduit net .| ons + withAsync src $ \as -> do + link as + runConduit (go .| snk) + send_msg p msg = publish (PeerMessage p msg) pub -- | Internal function to dispatch peer messages. -dispatchMessage :: MonadIO m - => PeerConfig - -> PeerMessage - -> ConduitT i Message m () -dispatchMessage _ (SendMessage msg) = yield msg -dispatchMessage _ (KillPeer e) = throwIO e +dispatchMessage :: + (MonadLoggerIO m) => + PeerConfig -> + PeerMessage -> + ConduitT i Message m () +dispatchMessage PeerConfig {label} (SendMessage msg) = do + $(logDebugS) "Peer" $ label <> " sending: " <> cs (show msg) + yield msg +dispatchMessage PeerConfig {label} (KillPeer e) = do + $(logInfoS) "Peer" $ label <> " killing with error: " <> cs (show e) + throwIO e -- | Internal conduit to parse messages coming from peer. -inPeerConduit :: MonadIO m - => Network - -> Text - -> ConduitT ByteString Message m () -inPeerConduit net a = - forever $ do - x <- takeCE 24 .| foldC - when (B.null x) $ do - throwIO EmptyHeader - case decode x of - Left e -> do - throwIO DecodeHeaderError - Right (MessageHeader _ cmd len _) -> do - when (len > 32 * 2 ^ (20 :: Int)) $ do - throwIO $ PayloadTooLarge len - y <- takeCE (fromIntegral len) .| foldC - case runGet (getMessage net) $ x `B.append` y of - Left e -> do - throwIO (CannotDecodePayload cmd) - Right msg -> yield msg +inPeerConduit :: + (MonadLoggerIO m) => + Network -> + PeerConfig -> + Text -> + ConduitT ByteString Message m () +inPeerConduit net PeerConfig {label} a = + forever $ do + $(logDebugS) "Peer" $ label <> " awaiting network message..." + x <- takeCE 24 .| foldC + when (B.null x) $ do + $(logErrorS) "Peer" $ label <> " empty header" + throwIO EmptyHeader + case decode x of + Left e -> do + $(logErrorS) "Peer" $ label <> " error decoding header" + throwIO DecodeHeaderError + Right (MessageHeader _ cmd len _) -> do + $(logDebugS) "Peer" $ label <> " received: " <> cs (show cmd) + when (len > 32 * 2 ^ (20 :: Int)) $ do + $(logErrorS) "Peer" $ label <> " payload too large: " <> cs (show len) + throwIO $ PayloadTooLarge len + y <- takeCE (fromIntegral len) .| foldC + case runGet (getMessage net) $ x `B.append` y of + Left e -> do + $(logErrorS) "Peer" $ + label + <> " could not decode payload for cmd: " + <> cs (show cmd) + throwIO (CannotDecodePayload cmd) + Right msg -> do + $(logDebugS) "Peer" $ label <> " forwarding: " <> cs (show msg) + yield msg -- | Outgoing peer conduit to serialize and send messages. -outPeerConduit :: Monad m => Network -> ConduitT Message ByteString m () +outPeerConduit :: (Monad m) => Network -> ConduitT Message ByteString m () outPeerConduit net = awaitForever $ yield . runPut . putMessage net -- | Kill a peer with the provided exception. -killPeer :: MonadIO m => PeerException -> Peer -> m () -killPeer e p = KillPeer e `send` peerMailbox p +killPeer :: (MonadIO m) => PeerException -> Peer -> m () +killPeer e p = KillPeer e `send` p.mailbox -- | Send a network message to peer. -sendMessage :: MonadIO m => Message -> Peer -> m () -sendMessage msg p = SendMessage msg `send` peerMailbox p +sendMessage :: (MonadIO m) => Message -> Peer -> m () +sendMessage msg p = SendMessage msg `send` p.mailbox -getBusy :: MonadIO m => Peer -> m Bool -getBusy p = readTVarIO (peerBusy p) +getBusy :: (MonadIO m) => Peer -> m Bool +getBusy p = readTVarIO p.busy -setBusy :: MonadIO m => Peer -> m Bool +setBusy :: (MonadIO m) => Peer -> m Bool setBusy p = - atomically $ - readTVar (peerBusy p) >>= \case - True -> return False - False -> writeTVar (peerBusy p) True >> - return True + atomically $ do + b <- readTVar p.busy + unless b $ writeTVar p.busy True + return $ not b -setFree :: MonadIO m => Peer -> m () -setFree p = atomically $ writeTVar (peerBusy p) False +setFree :: (MonadIO m) => Peer -> m () +setFree p = atomically $ writeTVar p.busy False -- | Request full blocks from peer. Will return 'Nothing' if the list of blocks -- returned by the peer is incomplete, comes out of order, or a timeout is -- reached. -getBlocks :: MonadUnliftIO m - => Network - -> Int - -> Peer - -> [BlockHash] - -> m (Maybe [Block]) +getBlocks :: + (MonadUnliftIO m) => + Network -> + Int -> + Peer -> + [BlockHash] -> + m (Maybe [Block]) getBlocks net time p bhs = - runMaybeT $ mapM f =<< MaybeT (getData time p (GetData ivs)) + runMaybeT $ mapM f =<< MaybeT (getData time p (GetData ivs)) where f (Right b) = return b - f (Left _) = MaybeT $ return Nothing + f (Left _) = MaybeT $ return Nothing c - | getSegWit net = InvWitnessBlock - | otherwise = InvBlock - ivs = map (InvVector c . getBlockHash) bhs + | net.segWit = InvWitnessBlock + | otherwise = InvBlock + ivs = map (InvVector c . (.get)) bhs -- | Request transactions from peer. Will return 'Nothing' if the list of -- transactions returned by the peer is incomplete, comes out of order, or a -- timeout is reached. -getTxs :: MonadUnliftIO m - => Network - -> Int - -> Peer - -> [TxHash] - -> m (Maybe [Tx]) +getTxs :: + (MonadUnliftIO m) => + Network -> + Int -> + Peer -> + [TxHash] -> + m (Maybe [Tx]) getTxs net time p ths = - runMaybeT $ mapM f =<< MaybeT (getData time p (GetData ivs)) + runMaybeT $ mapM f =<< MaybeT (getData time p (GetData ivs)) where f (Right _) = MaybeT $ return Nothing - f (Left t) = return t + f (Left t) = return t c - | getSegWit net = InvWitnessTx - | otherwise = InvTx - ivs = map (InvVector c . getTxHash) ths + | net.segWit = InvWitnessTx + | otherwise = InvTx + ivs = map (InvVector c . (.get)) ths -- | Request transactions and/or blocks from peer. Return 'Nothing' if any -- single inventory fails to be retrieved, if they come out of order, or if -- timeout is reached. -getData :: MonadUnliftIO m - => Int - -> Peer - -> GetData - -> m (Maybe [Either Tx Block]) +getData :: + (MonadUnliftIO m) => Int -> Peer -> GetData -> m (Maybe [Either Tx Block]) getData seconds p gd@(GetData ivs) = - withSubscription (peerPublisher p) $ \inb -> do - MGetData gd `sendMessage` p + withSubscription p.pub $ \inb -> do r <- liftIO randomIO + MGetData gd `sendMessage` p MPing (Ping r) `sendMessage` p - fmap join . timeout (seconds * 1000 * 1000) . - runMaybeT $ get_thing inb r [] ivs + fmap join + . timeout (seconds * 1000 * 1000) + . runMaybeT + $ get_thing inb r [] ivs where get_thing _inb _r acc [] = - return $ reverse acc + return $ reverse acc get_thing inb r acc hss@(InvVector t h : hs) = - filterReceive p inb >>= \case - MTx tx - | is_tx t && getTxHash (txHash tx) == h -> - get_thing inb r (Left tx : acc) hs - MBlock b@(Block bh _) - | is_block t && getBlockHash (headerHash bh) == h -> - get_thing inb r (Right b : acc) hs - MNotFound (NotFound nvs) - | not (null (nvs `union` hs)) -> - MaybeT $ return Nothing - MPong (Pong r') - | r == r' -> - MaybeT $ return Nothing - _ - | null acc -> - get_thing inb r acc hss - | otherwise -> - MaybeT $ return Nothing + filterReceive p inb >>= \case + MTx tx + | is_tx t && (txHash tx).get == h -> + get_thing inb r (Left tx : acc) hs + MBlock b@(Block bh _) + | is_block t && (headerHash bh).get == h -> + get_thing inb r (Right b : acc) hs + MNotFound (NotFound nvs) + | not (null (nvs `union` hs)) -> + MaybeT $ return Nothing + MPong (Pong r') + | r == r' -> + MaybeT $ return Nothing + _ + | null acc -> + get_thing inb r acc hss + | otherwise -> + MaybeT $ return Nothing is_tx InvWitnessTx = True - is_tx InvTx = True - is_tx _ = False + is_tx InvTx = True + is_tx _ = False is_block InvWitnessBlock = True - is_block InvBlock = True - is_block _ = False + is_block InvBlock = True + is_block _ = False -- | Ping a peer and await response. Return 'False' if response not received -- before timeout. -pingPeer :: MonadUnliftIO m => Int -> Peer -> m Bool +pingPeer :: (MonadUnliftIO m) => Int -> Peer -> m Bool pingPeer time p = - fmap isJust . withSubscription (peerPublisher p) $ \sub -> do - r <- liftIO randomIO - MPing (Ping r) `sendMessage` p - receiveMatchS time sub $ \case - (p', MPong (Pong r')) - | p == p' && r == r' -> Just () - _ -> Nothing - --- | Peer string for logging -peerLog :: Text -> Text -peerLog = mappend "Peer|" + fmap isJust . withSubscription p.pub $ \sub -> do + r <- liftIO randomIO + MPing (Ping r) `sendMessage` p + receiveMatchS time sub $ \case + PeerMessage p' (MPong (Pong r')) + | p == p' && r == r' -> Just () + _ -> Nothing -filterReceive :: MonadIO m => Peer -> Inbox (Peer, Message) -> m Message +filterReceive :: (MonadIO m) => Peer -> Inbox PeerEvent -> m Message filterReceive p inb = - receive inb >>= \case - (p', msg) | p == p' -> return msg - _ -> filterReceive p inb + receive inb >>= \case + PeerMessage p' msg | p == p' -> return msg + _ -> filterReceive p inb diff --git a/src/Haskoin/Node/PeerMgr.hs b/src/Haskoin/Node/PeerMgr.hs new file mode 100644 --- /dev/null +++ b/src/Haskoin/Node/PeerMgr.hs @@ -0,0 +1,867 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE NoFieldSelectors #-} + +module Haskoin.Node.PeerMgr + ( PeerMgrConfig (..), + PeerEvent (..), + OnlinePeer (..), + PeerMgr, + withPeerMgr, + peerMgrBest, + peerMgrVersion, + peerMgrPing, + peerMgrPong, + peerMgrAddrs, + peerMgrVerAck, + peerMgrTickle, + getPeers, + getOnlinePeer, + buildVersion, + myVersion, + toSockAddr, + toHostService, + ) +where + +import Control.Applicative ((<|>)) +import Control.Arrow +import Control.Monad + ( forM_, + forever, + guard, + unless, + void, + when, + (<=<), + ) +import Control.Monad.Except + ( ExceptT (..), + runExceptT, + throwError, + ) +import Control.Monad.Logger + ( MonadLogger, + MonadLoggerIO, + logDebugS, + logErrorS, + logInfoS, + logWarnS, + ) +import Control.Monad.Reader + ( MonadReader, + ReaderT (ReaderT), + ask, + asks, + runReaderT, + ) +import Control.Monad.Trans (lift) +import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) +import Data.Bits ((.&.)) +import Data.Function (on) +import Data.List (dropWhileEnd, elemIndex, find, nub, sort) +import Data.Maybe (fromMaybe, isJust) +import Data.Set (Set) +import qualified Data.Set as Set +import Data.String.Conversions (cs) +import Data.Time.Clock + ( NominalDiffTime, + UTCTime, + addUTCTime, + diffUTCTime, + getCurrentTime, + ) +import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) +import Data.Word (Word32, Word64) +import Haskoin + ( BlockHeight, + Message (..), + Network (..), + NetworkAddress (..), + Ping (..), + Pong (..), + VarString (..), + Version (..), + hostToSockAddr, + nodeNetwork, + sockToHostAddress, + ) +import Haskoin.Node.Peer +import NQE + ( Child, + Inbox, + Mailbox, + Publisher, + Strategy (..), + Supervisor, + addChild, + inboxToMailbox, + newInbox, + newMailbox, + publish, + receive, + receiveMatch, + send, + sendSTM, + withSupervisor, + ) +import Network.Socket + ( AddrInfo (..), + AddrInfoFlag (..), + Family (..), + SockAddr (..), + SocketType (..), + defaultHints, + getAddrInfo, + ) +import System.Random (randomIO, randomRIO) +import UnliftIO + ( Async, + MonadIO, + MonadUnliftIO, + STM, + SomeException, + TVar, + atomically, + catch, + liftIO, + link, + modifyTVar, + newTVarIO, + readTVar, + readTVarIO, + withAsync, + withRunInIO, + writeTVar, + ) +import UnliftIO.Concurrent (threadDelay) + +type MonadManager m = (MonadIO m, MonadReader PeerMgr m) + +data PeerMgrConfig = PeerMgrConfig + { maxPeers :: !Int, + peers :: ![String], + discover :: !Bool, + address :: !NetworkAddress, + net :: !Network, + pub :: !(Publisher PeerEvent), + timeout :: !NominalDiffTime, + maxPeerLife :: !NominalDiffTime, + connect :: !(SockAddr -> WithConnection) + } + +data PeerMgr = PeerMgr + { config :: !PeerMgrConfig, + supervisor :: !Supervisor, + mailbox :: !(Mailbox PeerMgrMessage), + best :: !(TVar BlockHeight), + addresses :: !(TVar (Set SockAddr)), + peers :: !(TVar [OnlinePeer]) + } + +data PeerMgrMessage + = Connect !SockAddr + | CheckPeer !Peer + | PeerDied !Child !(Maybe SomeException) + | ManagerBest !BlockHeight + | PeerVerAck !Peer + | PeerVersion !Peer !Version + | PeerPing !Peer !Word64 + | PeerPong !Peer !Word64 + | PeerAddrs !Peer ![NetworkAddress] + | PeerTickle !Peer + +-- | Data structure representing an online peer. +data OnlinePeer = OnlinePeer + { address :: !SockAddr, + verack :: !Bool, + online :: !Bool, + version :: !(Maybe Version), + async :: !(Async ()), + mailbox :: !Peer, + nonce :: !Word64, + ping :: !(Maybe (UTCTime, Word64)), + pings :: ![NominalDiffTime], + connected :: !UTCTime, + tickled :: !UTCTime + } + +instance Eq OnlinePeer where + (==) = (==) `on` f + where + f OnlinePeer {mailbox = p} = p + +instance Ord OnlinePeer where + compare = compare `on` f + where + f OnlinePeer {pings = pings} = fromMaybe 60 (median pings) + +withPeerMgr :: + (MonadUnliftIO m, MonadLoggerIO m) => + PeerMgrConfig -> + (PeerMgr -> m a) -> + m a +withPeerMgr cfg action = do + inbox <- newInbox + let mgr = inboxToMailbox inbox + withSupervisor (Notify (death mgr)) $ \sup -> do + bb <- newTVarIO 0 + kp <- newTVarIO Set.empty + ob <- newTVarIO [] + runReaderT + (go inbox) + PeerMgr + { config = cfg, + supervisor = sup, + mailbox = mgr, + best = bb, + addresses = kp, + peers = ob + } + where + death mgr (a, ex) = PeerDied a ex `sendSTM` mgr + go inbox = + withAsync (peerManager inbox) $ \a -> + withConnectLoop $ + link a >> ReaderT action + +peerManager :: + ( MonadUnliftIO m, + MonadManager m, + MonadLoggerIO m + ) => + Inbox PeerMgrMessage -> + m () +peerManager inb = do + $(logDebugS) "PeerMgr" "Awaiting best block" + putBestBlock <=< receiveMatch inb $ \case + ManagerBest b -> Just b + _ -> Nothing + $(logDebugS) "PeerMgr" "Starting peer manager actor" + forever $ do + $(logDebugS) "PeerMgr" "Awaiting event..." + dispatch =<< receive inb + +putBestBlock :: (MonadManager m) => BlockHeight -> m () +putBestBlock bb = do + b <- asks (.best) + atomically $ writeTVar b bb + +getBestBlock :: (MonadManager m) => m BlockHeight +getBestBlock = + asks (.best) >>= readTVarIO + +getNetwork :: (MonadManager m) => m Network +getNetwork = + asks (.config.net) + +loadPeers :: (MonadUnliftIO m, MonadManager m) => m () +loadPeers = do + loadStaticPeers + loadNetSeeds + +loadStaticPeers :: (MonadUnliftIO m, MonadManager m) => m () +loadStaticPeers = do + net <- asks (.config.net) + xs <- asks (.config.peers) + mapM_ newPeer . concat =<< mapM (toSockAddr net) xs + +loadNetSeeds :: (MonadUnliftIO m, MonadManager m) => m () +loadNetSeeds = + asks (.config.discover) >>= \discover -> + when discover $ do + net <- getNetwork + ss <- concat <$> mapM (toSockAddr net) net.seeds + mapM_ newPeer ss + +logConnectedPeers :: (MonadManager m, MonadLoggerIO m) => m () +logConnectedPeers = do + m <- asks (.config.maxPeers) + l <- length <$> getConnectedPeers + $(logInfoS) "PeerMgr" $ + "Peers connected: " <> cs (show l) <> "/" <> cs (show m) + +getOnlinePeers :: (MonadManager m) => m [OnlinePeer] +getOnlinePeers = + asks (.peers) >>= readTVarIO + +getConnectedPeers :: (MonadManager m) => m [OnlinePeer] +getConnectedPeers = + filter (.online) <$> getOnlinePeers + +managerEvent :: (MonadManager m) => PeerEvent -> m () +managerEvent e = + publish e =<< asks (.config.pub) + +dispatch :: + ( MonadUnliftIO m, + MonadManager m, + MonadLoggerIO m + ) => + PeerMgrMessage -> + m () +dispatch (PeerVersion p v) = do + $(logDebugS) "PeerMgr" $ + "Received peer " <> p.label <> " version: " <> cs (show v) + b <- asks (.peers) + e <- runExceptT $ do + o <- ExceptT . atomically $ setPeerVersion b p v + when o.online $ announcePeer p + case e of + Right () -> do + $(logDebugS) "PeerMgr" $ + "Sending version ack to peer: " <> p.label + MVerAck `sendMessage` p + Left x -> do + $(logErrorS) "PeerMgr" $ + "Version rejected for peer " + <> p.label + <> ": " + <> cs (show x) + killPeer x p +dispatch (PeerVerAck p) = do + b <- asks (.peers) + atomically (setPeerVerAck b p) >>= \case + Just o -> do + $(logDebugS) "PeerMgr" $ + "Received version ack from peer: " + <> p.label + when o.online $ + announcePeer p + Nothing -> do + $(logErrorS) "PeerMgr" $ + "Received verack from unknown peer: " + <> p.label + killPeer UnknownPeer p +dispatch (PeerAddrs p nas) = do + $(logDebugS) "PeerMgr" $ + "Received addresses from peer " <> p.label + discover <- asks (.config.discover) + when discover $ do + let sas = map (hostToSockAddr . (.address)) nas + forM_ (zip [(1 :: Int) ..] sas) $ \(i, a) -> do + $(logDebugS) "PeerMgr" $ + "Got peer address " + <> cs (show i) + <> "/" + <> cs (show (length sas)) + <> ": " + <> cs (show a) + <> " from peer " + <> p.label + newPeer a +dispatch (PeerPong p n) = do + b <- asks (.peers) + $(logDebugS) "PeerMgr" $ + "Received pong " + <> cs (show n) + <> " from: " + <> p.label + now <- liftIO getCurrentTime + atomically (gotPong b n now p) +dispatch (PeerPing p n) = do + $(logDebugS) "PeerMgr" $ + "Responding to ping " + <> cs (show n) + <> " from: " + <> p.label + MPong (Pong n) `sendMessage` p +dispatch (ManagerBest h) = do + $(logDebugS) "PeerMgr" $ + "Setting best block to " <> cs (show h) + putBestBlock h +dispatch (Connect sa) = do + connectPeer sa +dispatch (PeerDied a e) = do + processPeerOffline a e +dispatch (CheckPeer p) = do + $(logDebugS) "PeerManager" $ + "Housekeeping for peer " <> p.label + checkPeer p +dispatch (PeerTickle p) = do + $(logDebugS) "PeerMgr" $ + "Tickled peer " <> p.label + b <- asks (.peers) + now <- liftIO getCurrentTime + atomically $ + modifyPeer b p $ \o -> + o {tickled = now} + +checkPeer :: (MonadManager m, MonadLoggerIO m) => Peer -> m () +checkPeer p = do + busy <- getBusy p + b <- asks (.peers) + mp <- asks (.peers) >>= atomically . flip findPeer p + case mp of + Nothing -> return () + Just o -> + liftIO getCurrentTime >>= \now -> do + maxLife <- asks (.config.maxPeerLife) + let disconnect = maxLife `addUTCTime` o.connected + when (now > disconnect) $ do + $(logErrorS) "PeerMgr" $ + "Disconnecting old peer " + <> p.label + <> " online since " + <> cs (show o.connected) + killPeer PeerTooOld p + timeout <- asks (.config.timeout) + let pingTime = timeout `addUTCTime` o.tickled + when (now > pingTime) $ + case o.ping of + Nothing -> + sendPing p + Just _ -> do + $(logWarnS) "PeerMgr" $ + "Peer ping timeout: " <> p.label + killPeer PeerTimeout p + +sendPing :: (MonadManager m, MonadLoggerIO m) => Peer -> m () +sendPing p = do + b <- asks (.peers) + atomically (findPeer b p) >>= \case + Nothing -> + $(logWarnS) "PeerMgr" $ + "Will not ping unknown peer: " <> p.label + Just o + | o.online -> do + n <- liftIO randomIO + now <- liftIO getCurrentTime + atomically (setPeerPing b n now p) + $(logDebugS) " PeerManager" $ + "Sending ping " + <> cs (show n) + <> " to: " + <> p.label + MPing (Ping n) `sendMessage` p + | otherwise -> return () + +processPeerOffline :: + (MonadManager m, MonadLoggerIO m) => + Child -> + Maybe SomeException -> + m () +processPeerOffline a e = do + b <- asks (.peers) + atomically (findPeerAsync b a) >>= \case + Nothing -> log_unknown e + Just o -> do + let p = o.mailbox + if o.online + then do + log_disconnected p e + managerEvent $ PeerDisconnected p + else log_not_connect p e + atomically $ removePeer b p + logConnectedPeers + where + log_unknown Nothing = + $(logErrorS) + "PeerMgr" + "Disconnected unknown peer" + log_unknown (Just x) = + $(logErrorS) "PeerMgr" $ + "Unknown peer died: " <> cs (show x) + log_disconnected p Nothing = + $(logWarnS) "PeerMgr" $ + "Disconnected peer: " <> p.label + log_disconnected p (Just x) = + $(logErrorS) "PeerMgr" $ + "Peer " <> p.label <> " died: " <> cs (show x) + log_not_connect p Nothing = + $(logWarnS) "PeerMgr" $ + "Could not connect to peer " <> p.label + log_not_connect p (Just x) = + $(logErrorS) "PeerMgr" $ + "Could not connect to peer " + <> p.label + <> ": " + <> cs (show x) + +announcePeer :: (MonadManager m, MonadLoggerIO m) => Peer -> m () +announcePeer p = do + b <- asks (.peers) + atomically (findPeer b p) >>= \case + Just OnlinePeer {online = True} -> do + $(logInfoS) "PeerMgr" $ + "Connected to peer " <> p.label + managerEvent $ PeerConnected p + logConnectedPeers + Just OnlinePeer {online = False} -> + return () + Nothing -> + $(logErrorS) "PeerMgr" $ + "Not announcing disconnected peer: " + <> p.label + +getNewPeer :: (MonadUnliftIO m, MonadManager m) => m (Maybe SockAddr) +getNewPeer = + runMaybeT $ lift loadPeers >> go + where + go = do + b <- asks (.addresses) + ks <- readTVarIO b + guard . not $ Set.null ks + let xs = Set.toList ks + a <- liftIO $ randomRIO (0, length xs - 1) + let p = xs !! a + o <- asks (.peers) + m <- atomically $ do + modifyTVar b $ Set.delete p + findPeerAddress o p + maybe (return p) (const go) m + +connectPeer :: + ( MonadUnliftIO m, + MonadManager m, + MonadLoggerIO m + ) => + SockAddr -> + m () +connectPeer sa = do + os <- asks (.peers) + atomically (findPeerAddress os sa) >>= \case + Just _ -> + $(logErrorS) "PeerMgr" $ + "Attempted to connect to peer twice: " <> cs (show sa) + Nothing -> do + $(logInfoS) "PeerMgr" $ "Connecting to " <> cs (show sa) + PeerMgrConfig + { address = ad, + net = net + } <- + asks (.config) + sup <- asks (.supervisor) + conn <- asks (.config.connect) + pub <- asks (.config.pub) + nonce <- liftIO randomIO + bb <- getBestBlock + now <- liftIO getCurrentTime + let rmt = NetworkAddress (srv net) (sockToHostAddress sa) + unix = floor (utcTimeToPOSIXSeconds now) + ver = buildVersion net nonce bb ad rmt unix + text = cs (show sa) + (inbox, mailbox) <- newMailbox + let pc = + PeerConfig + { pub = pub, + net = net, + label = text, + connect = conn sa + } + busy <- newTVarIO False + p <- wrapPeer pc busy mailbox + a <- withRunInIO $ \io -> + sup `addChild` io (launch pc busy inbox p) + MVersion ver `sendMessage` p + b <- asks (.peers) + atomically $ + insertPeer + b + OnlinePeer + { address = sa, + verack = False, + online = False, + version = Nothing, + async = a, + mailbox = p, + nonce = nonce, + pings = [], + ping = Nothing, + connected = now, + tickled = now + } + where + srv net + | net.segWit = 8 + | otherwise = 0 + launch pc busy inbox p = + ask >>= \mgr -> + withPeerLoop sa p mgr $ \a -> + link a >> peer pc busy inbox + +withPeerLoop :: + (MonadUnliftIO m, MonadLogger m) => + SockAddr -> + Peer -> + PeerMgr -> + (Async a -> m a) -> + m a +withPeerLoop _ p mgr = + withAsync . forever $ do + let x = mgr.config.timeout + y = floor (x * 1000000) + r <- liftIO $ randomRIO (y * 3 `div` 4, y) + threadDelay r + managerCheck p mgr + +withConnectLoop :: + (MonadUnliftIO m, MonadManager m) => + m a -> + m a +withConnectLoop act = + withAsync go $ \a -> + link a >> act + where + go = forever $ do + l <- length <$> getOnlinePeers + x <- asks (.config.maxPeers) + when (l < x) $ + getNewPeer >>= mapM_ (\sa -> ask >>= managerConnect sa) + delay <- + liftIO $ + randomRIO + ( 100 * 1000, + 10 * 500 * 1000 + ) + threadDelay delay + +newPeer :: (MonadIO m, MonadManager m) => SockAddr -> m () +newPeer sa = do + b <- asks (.addresses) + o <- asks (.peers) + atomically $ + findPeerAddress o sa >>= \case + Just _ -> return () + Nothing -> modifyTVar b $ Set.insert sa + +gotPong :: TVar [OnlinePeer] -> Word64 -> UTCTime -> Peer -> STM () +gotPong b nonce now p = void . runMaybeT $ do + o <- MaybeT (findPeer b p) + (time, old_nonce) <- MaybeT (return o.ping) + guard $ nonce == old_nonce + let diff = now `diffUTCTime` time + lift $ + insertPeer + b + o + { ping = Nothing, + pings = sort $ take 11 $ diff : o.pings + } + +setPeerPing :: TVar [OnlinePeer] -> Word64 -> UTCTime -> Peer -> STM () +setPeerPing b nonce now p = + modifyPeer b p $ \o -> o {ping = Just (now, nonce)} + +setPeerVersion :: + TVar [OnlinePeer] -> + Peer -> + Version -> + STM (Either PeerException OnlinePeer) +setPeerVersion b p v = runExceptT $ do + when (v.services .&. nodeNetwork == 0) $ + throwError NotNetworkPeer + ops <- lift $ readTVar b + when (any ((v.nonce ==) . (.nonce)) ops) $ + throwError PeerIsMyself + lift (findPeer b p) >>= \case + Nothing -> throwError UnknownPeer + Just o -> do + let n = + o + { version = Just v, + online = o.verack + } + lift $ insertPeer b n + return n + +setPeerVerAck :: TVar [OnlinePeer] -> Peer -> STM (Maybe OnlinePeer) +setPeerVerAck b p = runMaybeT $ do + o <- MaybeT $ findPeer b p + let n = + o + { verack = True, + online = isJust o.version + } + lift $ insertPeer b n + return n + +findPeer :: TVar [OnlinePeer] -> Peer -> STM (Maybe OnlinePeer) +findPeer b p = + find ((== p) . (.mailbox)) + <$> readTVar b + +insertPeer :: TVar [OnlinePeer] -> OnlinePeer -> STM () +insertPeer b o = + modifyTVar b $ \x -> sort . nub $ o : x + +modifyPeer :: + TVar [OnlinePeer] -> + Peer -> + (OnlinePeer -> OnlinePeer) -> + STM () +modifyPeer b p f = + findPeer b p >>= \case + Nothing -> return () + Just o -> insertPeer b $ f o + +removePeer :: TVar [OnlinePeer] -> Peer -> STM () +removePeer b p = + modifyTVar b $ + filter ((/= p) . (.mailbox)) + +findPeerAsync :: + TVar [OnlinePeer] -> + Async () -> + STM (Maybe OnlinePeer) +findPeerAsync b a = + find ((== a) . (.async)) + <$> readTVar b + +findPeerAddress :: + TVar [OnlinePeer] -> + SockAddr -> + STM (Maybe OnlinePeer) +findPeerAddress b a = + find ((== a) . (.address)) + <$> readTVar b + +getPeers :: (MonadIO m) => PeerMgr -> m [OnlinePeer] +getPeers = runReaderT getConnectedPeers + +getOnlinePeer :: + (MonadIO m) => + Peer -> + PeerMgr -> + m (Maybe OnlinePeer) +getOnlinePeer p = + runReaderT $ asks (.peers) >>= atomically . (`findPeer` p) + +managerCheck :: (MonadIO m) => Peer -> PeerMgr -> m () +managerCheck p mgr = + CheckPeer p `send` mgr.mailbox + +managerConnect :: (MonadIO m) => SockAddr -> PeerMgr -> m () +managerConnect sa mgr = + Connect sa `send` mgr.mailbox + +peerMgrBest :: (MonadIO m) => BlockHeight -> PeerMgr -> m () +peerMgrBest bh mgr = + ManagerBest bh `send` mgr.mailbox + +peerMgrVerAck :: (MonadIO m) => Peer -> PeerMgr -> m () +peerMgrVerAck p mgr = + PeerVerAck p `send` mgr.mailbox + +peerMgrVersion :: + (MonadIO m) => + Peer -> + Version -> + PeerMgr -> + m () +peerMgrVersion p ver mgr = + PeerVersion p ver `send` mgr.mailbox + +peerMgrPing :: + (MonadIO m) => + Peer -> + Word64 -> + PeerMgr -> + m () +peerMgrPing p nonce mgr = + PeerPing p nonce `send` mgr.mailbox + +peerMgrPong :: + (MonadIO m) => + Peer -> + Word64 -> + PeerMgr -> + m () +peerMgrPong p nonce mgr = + PeerPong p nonce `send` mgr.mailbox + +peerMgrAddrs :: + (MonadIO m) => + Peer -> + [NetworkAddress] -> + PeerMgr -> + m () +peerMgrAddrs p addrs mgr = + PeerAddrs p addrs `send` mgr.mailbox + +peerMgrTickle :: + (MonadIO m) => + Peer -> + PeerMgr -> + m () +peerMgrTickle p mgr = + PeerTickle p `send` mgr.mailbox + +toHostService :: String -> (Maybe String, Maybe String) +toHostService str = + let host = case m6 of + Just (x, _) -> Just x + Nothing -> case takeWhile (/= ':') str of + [] -> Nothing + xs -> Just xs + srv = case m6 of + Just (_, y) -> s y + Nothing -> s str + s xs = + case dropWhile (/= ':') xs of + [] -> Nothing + _ : ys -> Just ys + m6 = case str of + (x : xs) + | x == '[' -> do + i <- elemIndex ']' xs + return $ second tail $ splitAt i xs + | x == ':' -> do + return (str, "") + _ -> Nothing + in (host, srv) + +toSockAddr :: (MonadUnliftIO m) => Network -> String -> m [SockAddr] +toSockAddr net str = + go `catch` e + where + go = fmap (map addrAddress) $ liftIO $ getAddrInfo Nothing host srv + (host, srv) = + second (<|> Just (show net.defaultPort)) $ + toHostService str + e :: (Monad m) => SomeException -> m [SockAddr] + e _ = return [] + +median :: (Ord a, Fractional a) => [a] -> Maybe a +median ls + | null ls = + Nothing + | even (length ls) = + Just . (/ 2) . sum . take 2 $ + drop (length ls `div` 2 - 1) ls' + | otherwise = + Just (ls' !! (length ls `div` 2)) + where + ls' = sort ls + +buildVersion :: + Network -> + Word64 -> + BlockHeight -> + NetworkAddress -> + NetworkAddress -> + Word64 -> + Version +buildVersion net nonce height loc rmt time = + Version + { version = myVersion, + services = loc.services, + timestamp = time, + addrRecv = rmt, + addrSend = loc, + nonce = nonce, + userAgent = VarString net.userAgent, + startHeight = height, + relay = True + } + +myVersion :: Word32 +myVersion = 70012 diff --git a/test/Haskoin/NodeSpec.hs b/test/Haskoin/NodeSpec.hs --- a/test/Haskoin/NodeSpec.hs +++ b/test/Haskoin/NodeSpec.hs @@ -1,294 +1,340 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -module Haskoin.NodeSpec - ( spec - ) where +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NoFieldSelectors #-} -import Conduit (awaitForever, concatMapC, foldC, mapMC, - runConduit, takeCE, yield, (.|)) -import Control.Monad (forM_, forever, replicateM) -import Control.Monad.Logger (runNoLoggingT) -import Control.Monad.Trans (lift) -import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import Data.ByteString.Base64 (decodeBase64Lenient) -import Data.Default (def) -import Data.Either (fromRight) -import Data.List (find) -import Data.Maybe (isJust, mapMaybe) -import Data.Serialize (decode, get, runGet, runPut) -import Data.Time.Clock.POSIX (getPOSIXTime) -import qualified Database.RocksDB as R -import Haskoin (Block (..), BlockHash (..), - BlockHeader (..), BlockNode (..), - GetData (..), GetHeaders (..), - Headers (..), InvType (..), - InvVector (..), Message (..), - MessageHeader (..), Network (..), - NetworkAddress (..), Ping (..), - Pong (..), VarInt (..), Version (..), - bchRegTest, buildMerkleRoot, - getMessage, headerHash, nodeNetwork, - putMessage, sockToHostAddress, txHash) -import Haskoin.Node -import Network.Socket (SockAddr (..), AddrInfo (addrAddress)) -import NQE (Inbox, Mailbox, inboxToMailbox, - newInbox, receive, receiveMatch, send, - withPublisher, withSubscription) -import System.Random (randomIO) -import Test.Hspec -import Test.Hspec.QuickCheck -import UnliftIO (MonadIO, MonadUnliftIO, liftIO, - throwString, withAsync, - withSystemTempDirectory) +module Haskoin.NodeSpec (spec) where +import Conduit + ( awaitForever, + concatMapC, + foldC, + mapMC, + runConduit, + takeCE, + yield, + (.|), + ) +import Control.Monad (forM_, forever, replicateM) +import Control.Monad.Cont +import Control.Monad.Logger (runNoLoggingT) +import Control.Monad.Trans (lift) +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import Data.ByteString.Base64 (decodeBase64Lenient) +import Data.Default (def) +import Data.Either (fromRight) +import Data.List (find) +import Data.Maybe (isJust, mapMaybe) +import Data.Serialize (decode, get, runGet, runPut) +import Data.Time.Clock.POSIX (getPOSIXTime) +import qualified Database.RocksDB as R +import Haskoin + ( Block (..), + BlockHash (..), + BlockHeader (..), + BlockNode (..), + GetData (..), + GetHeaders (..), + Headers (..), + InvType (..), + InvVector (..), + Message (..), + MessageHeader (..), + Network (..), + NetworkAddress (..), + Ping (..), + Pong (..), + VarInt (..), + Version (..), + bchRegTest, + buildMerkleRoot, + getMessage, + headerHash, + nodeNetwork, + putMessage, + sockToHostAddress, + txHash, + ) +import Haskoin.Node +import NQE + ( Inbox, + Mailbox, + inboxToMailbox, + newInbox, + receive, + receiveMatch, + send, + withPublisher, + withSubscription, + ) +import Network.Socket (AddrInfo (addrAddress), SockAddr (..)) +import System.Random (randomIO) +import Test.Hspec +import Test.Hspec.QuickCheck +import UnliftIO + ( MonadIO, + MonadUnliftIO, + liftIO, + throwString, + withAsync, + withSystemTempDirectory, + ) + data TestNode = TestNode - { testMgr :: PeerManager - , testChain :: Chain - , nodeEvents :: Inbox NodeEvent - } + { testMgr :: PeerMgr, + testChain :: Chain, + nodeEvents :: Inbox NodeEvent + } -dummyPeerConnect :: Network - -> NetworkAddress - -> SockAddr - -> WithConnection +dummyPeerConnect :: + Network -> + NetworkAddress -> + SockAddr -> + WithConnection dummyPeerConnect net ad sa f = do - r <- newInbox - s <- newInbox - let s' = inboxToMailbox s - withAsync (go r s') $ \_ -> do - let o = awaitForever (`send` r) - i = forever (receive s >>= yield) - f (Conduits i o) :: IO () + r <- newInbox + s <- newInbox + let s' = inboxToMailbox s + withAsync (go r s') $ \_ -> do + let o = awaitForever (`send` r) + i = forever (receive s >>= yield) + f (Conduits i o) :: IO () where go :: Inbox ByteString -> Mailbox ByteString -> IO () go r s = do - nonce <- randomIO - now <- round <$> liftIO getPOSIXTime - let rmt = NetworkAddress 0 (sockToHostAddress sa) - ver = buildVersion net nonce 0 ad rmt now - runPut (putMessage net (MVersion ver)) `send` s - runConduit $ - forever (receive r >>= yield) .| inc .| concatMapC mockPeerReact .| - outc .| - awaitForever (`send` s) + nonce <- randomIO + now <- round <$> liftIO getPOSIXTime + let rmt = NetworkAddress 0 (sockToHostAddress sa) + ver = buildVersion net nonce 0 ad rmt now + runPut (putMessage net (MVersion ver)) `send` s + runConduit $ + forever (receive r >>= yield) + .| inc + .| concatMapC mockPeerReact + .| outc + .| awaitForever (`send` s) outc = mapMC $ \msg -> return $ runPut (putMessage net msg) inc = - forever $ do - x <- takeCE 24 .| foldC - case decode x of - Left _ -> error "Dummy peer not decode message header" - Right (MessageHeader _ _ len _) -> do - y <- takeCE (fromIntegral len) .| foldC - case runGet (getMessage net) $ x `B.append` y of - Left e -> - error $ - "Dummy peer could not decode payload: " <> show e - Right msg -> yield msg + forever $ do + x <- takeCE 24 .| foldC + y <- case decode x of + Left _ -> error "Dummy peer not decode message header" + Right (MessageHeader _ _ len _) -> + takeCE (fromIntegral len) .| foldC + case runGet (getMessage net) $ x `B.append` y of + Left e -> + error $ + "Dummy peer could not decode payload: " <> show e + Right msg -> yield msg mockPeerReact :: Message -> [Message] mockPeerReact (MPing (Ping n)) = [MPong (Pong n)] mockPeerReact (MVersion _) = [MVerAck] mockPeerReact (MGetHeaders (GetHeaders _ _hs _)) = [MHeaders (Headers hs')] where - f b = (blockHeader b, VarInt (fromIntegral (length (blockTxns b)))) + f b = (b.header, (VarInt . fromIntegral . length) b.txs) hs' = map f allBlocks mockPeerReact (MGetData (GetData ivs)) = mapMaybe f ivs where f (InvVector InvBlock h) = MBlock <$> find (l h) allBlocks - f _ = Nothing - l h b = headerHash (blockHeader b) == BlockHash h + f _ = Nothing + l h b = headerHash b.header == BlockHash h mockPeerReact _ = [] - spec :: Spec spec = do - let net = bchRegTest - describe "reads address/port combinations" $ do - prop "reads arbitrary addresses" $ \(e, w1, w2, w3, w4, b) -> do - let p = toEnum (e `mod` 65536) - a = if b - then SockAddrInet p w1 - else SockAddrInet6 p 0 (w1, w2, w3, w4) 0 - s <- head <$> toSockAddr net (show a) - s `shouldBe` a - it "reads some specific addresses" $ do - toHostService "localhost" `shouldBe` (Just "localhost", Nothing) - toHostService "::1" `shouldBe` (Just "::1", Nothing) - toHostService "localhost:8080" `shouldBe` (Just "localhost", Just "8080") - toHostService "example.com" `shouldBe` (Just "example.com", Nothing) - toHostService "api.example.com:443" `shouldBe` (Just "api.example.com", Just "443") - toHostService "api.example.com:http" `shouldBe` (Just "api.example.com", Just "http") - toHostService "[::1]" `shouldBe` (Just "::1", Nothing) - toHostService "[::1]:8080" `shouldBe` (Just "::1", Just "8080") - toHostService "[2002::dead:beef]:ssh" `shouldBe` (Just "2002::dead:beef", Just "ssh") - describe "peer manager on test network" $ do - it "connects to a peer" $ - withTestNode net "connect-one-peer" $ \TestNode {..} -> do - p <- waitForPeer nodeEvents - Just OnlinePeer {onlinePeerVersion = Just Version {version = ver}} <- - getOnlinePeer p testMgr - ver `shouldSatisfy` (>= 70002) - it "downloads some blocks" $ - withTestNode net "get-blocks" $ \TestNode {..} -> do - let h1 = - "3094ed3592a06f3d8e099eed2d9c1192329944f5df4a48acb29e08f12cfbb660" - h2 = - "0c89955fc5c9f98ecc71954f167b938138c90c6a094c4737f2e901669d26763f" - p <- waitForPeer nodeEvents - pbs <- getBlocks net 10 p [h1, h2] - pbs `shouldSatisfy` isJust - let Just [b1, b2] = pbs - headerHash (blockHeader b1) `shouldBe` h1 - headerHash (blockHeader b2) `shouldBe` h2 - let testMerkle b = - merkleRoot (blockHeader b) `shouldBe` - buildMerkleRoot (map txHash (blockTxns b)) - testMerkle b1 - testMerkle b2 - describe "chain on test network" $ do - it "syncs some headers" $ - withTestNode net "connect-sync" $ \TestNode {..} -> do - let bh = - "3bfa0c6da615fc45aa44ddea6854ac19d16f3ca167e0e21ac2cc262a49c9b002" - ah = - "7dc835a78a55fa76f9184dc4f6663a73e418c7afec789c5ae25e432fd7fc8467" - bn <- - receiveMatch nodeEvents $ \case - ChainEvent (ChainBestBlock bn) - | nodeHeight bn > 0 -> Just bn - _ -> Nothing - bb <- chainGetBest testChain - nodeHeight bb `shouldSatisfy` (== 15) - an <- - maybe (throwString "No ancestor found") return =<< - chainGetAncestor 10 bn testChain - headerHash (nodeHeader bn) `shouldBe` bh - headerHash (nodeHeader an) `shouldBe` ah - it "downloads some block parents" $ - withTestNode net "parents" $ \TestNode {..} -> do - let hs = - [ "52e886df7b166d961ac2d3d2d561d806325d51a609dc0a5d9d5fcb65d47906d7" - , "2537a081b9e2b24d217fac2886f387758cb3aa4e4956b3be7ed229bafbb71b0f" - , "7c72f306215a296f9714320a497b1f2cb5f9b99f162d7e04333c243fac9a54d8" - ] - [_, bn] <- - replicateM 2 $ - receiveMatch nodeEvents $ \case - ChainEvent (ChainBestBlock bn) -> Just bn - _ -> Nothing - nodeHeight bn `shouldBe` 15 - ps <- chainGetParents 12 bn testChain - length ps `shouldBe` 3 - forM_ (zip ps hs) $ \(p, h) -> - headerHash (nodeHeader p) `shouldBe` h + let net = bchRegTest + describe "reads address/port combinations" $ do + prop "reads arbitrary addresses" $ \(e, w1, w2, w3, w4, b) -> do + let p = toEnum (e `mod` 65536) + a = + if b + then SockAddrInet p w1 + else SockAddrInet6 p 0 (w1, w2, w3, w4) 0 + s <- head <$> toSockAddr net (show a) + s `shouldBe` a + it "reads some specific addresses" $ do + toHostService "localhost" `shouldBe` (Just "localhost", Nothing) + toHostService "::1" `shouldBe` (Just "::1", Nothing) + toHostService "localhost:8080" `shouldBe` (Just "localhost", Just "8080") + toHostService "example.com" `shouldBe` (Just "example.com", Nothing) + toHostService "api.example.com:443" `shouldBe` (Just "api.example.com", Just "443") + toHostService "api.example.com:http" `shouldBe` (Just "api.example.com", Just "http") + toHostService "[::1]" `shouldBe` (Just "::1", Nothing) + toHostService "[::1]:8080" `shouldBe` (Just "::1", Just "8080") + toHostService "[2002::dead:beef]:ssh" `shouldBe` (Just "2002::dead:beef", Just "ssh") + describe "peer manager on test network" $ do + it "connects to a peer" $ + withTestNode net "connect-one-peer" $ \TestNode {..} -> do + p <- waitForPeer nodeEvents + Just OnlinePeer {version = Just Version {version = ver}} <- + getOnlinePeer p testMgr + ver `shouldSatisfy` (>= 70002) + it "downloads some blocks" $ + withTestNode net "get-blocks" $ \TestNode {..} -> do + let h1 = + "3094ed3592a06f3d8e099eed2d9c1192329944f5df4a48acb29e08f12cfbb660" + h2 = + "0c89955fc5c9f98ecc71954f167b938138c90c6a094c4737f2e901669d26763f" + p <- waitForPeer nodeEvents + pbs <- getBlocks net 10 p [h1, h2] + pbs `shouldSatisfy` isJust + let Just [b1, b2] = pbs + headerHash b1.header `shouldBe` h1 + headerHash b2.header `shouldBe` h2 + let ths b = map txHash b.txs + testMerkle b = b.header.merkle `shouldBe` buildMerkleRoot (ths b) + testMerkle b1 + testMerkle b2 + describe "chain on test network" $ do + it "syncs some headers" $ + withTestNode net "connect-sync" $ \TestNode {..} -> do + let bh = + "3bfa0c6da615fc45aa44ddea6854ac19d16f3ca167e0e21ac2cc262a49c9b002" + ah = + "7dc835a78a55fa76f9184dc4f6663a73e418c7afec789c5ae25e432fd7fc8467" + bn <- + receiveMatch nodeEvents $ \case + ChainEvent (ChainBestBlock bn) + | bn.height > 0 -> Just bn + _ -> Nothing + bb <- chainGetBest testChain + bb.height `shouldSatisfy` (== 15) + an <- + maybe (throwString "No ancestor found") return + =<< chainGetAncestor 10 bn testChain + headerHash bn.header `shouldBe` bh + headerHash an.header `shouldBe` ah + it "downloads some block parents" $ + withTestNode net "parents" $ \TestNode {..} -> do + let hs = + [ "52e886df7b166d961ac2d3d2d561d806325d51a609dc0a5d9d5fcb65d47906d7", + "2537a081b9e2b24d217fac2886f387758cb3aa4e4956b3be7ed229bafbb71b0f", + "7c72f306215a296f9714320a497b1f2cb5f9b99f162d7e04333c243fac9a54d8" + ] + [_, bn] <- + replicateM 2 $ + receiveMatch nodeEvents $ \case + ChainEvent (ChainBestBlock bn) -> Just bn + _ -> Nothing + bn.height `shouldBe` 15 + ps <- chainGetParents 12 bn testChain + length ps `shouldBe` 3 + forM_ (zip ps hs) $ \(p, h) -> + headerHash p.header `shouldBe` h -waitForPeer :: MonadIO m => Inbox NodeEvent -> m Peer +waitForPeer :: (MonadIO m) => Inbox NodeEvent -> m Peer waitForPeer inbox = - receiveMatch inbox $ \case - PeerEvent (PeerConnected p) -> Just p - _ -> Nothing + receiveMatch inbox $ \case + PeerEvent (PeerConnected p) -> Just p + _ -> Nothing withTestNode :: - MonadUnliftIO m - => Network - -> String - -> (TestNode -> m a) - -> m a -withTestNode net str f = - runNoLoggingT $ - withSystemTempDirectory ("haskoin-node-test-" <> str <> "-") $ \w -> - withPublisher $ \pub -> - R.withDBCF w cfg cols $ \db -> do - let ad = NetworkAddress - nodeNetwork - (sockToHostAddress (SockAddrInet 0 0)) - na = NetworkAddress - 0 - (sockToHostAddress (SockAddrInet 0 0)) - cfg' = NodeConfig - { nodeConfMaxPeers = 20 - , nodeConfDB = db - , nodeConfColumnFamily = Just (head (R.columnFamilies db)) - , nodeConfPeers = ["[::1]:17486"] - , nodeConfDiscover = False - , nodeConfNetAddr = na - , nodeConfNet = net - , nodeConfEvents = pub - , nodeConfTimeout = 120 - , nodeConfPeerMaxLife = 48 * 3600 - , nodeConfConnect = dummyPeerConnect net ad - } - withNode cfg' $ \(Node mgr ch) -> - withSubscription pub $ \sub -> - lift $ - f TestNode { testMgr = mgr - , testChain = ch - , nodeEvents = sub - } + (MonadUnliftIO m) => + Network -> + String -> + (TestNode -> m a) -> + m a +withTestNode net str f = runNoLoggingT $ flip runContT return $ do + w <- ContT $ withSystemTempDirectory ("haskoin-node-test-" <> str <> "-") + pub <- ContT withPublisher + sub <- ContT $ withSubscription pub + db <- ContT $ R.withDBCF w cfg cols + let ad = + NetworkAddress + nodeNetwork + (sockToHostAddress (SockAddrInet 0 0)) + na = + NetworkAddress + 0 + (sockToHostAddress (SockAddrInet 0 0)) + cfg' = + NodeConfig + { maxPeers = 20, + db = db, + cf = Just (head (R.columnFamilies db)), + peers = ["[::1]:17486"], + discover = False, + address = na, + net = net, + pub = pub, + timeout = 120, + maxPeerLife = 48 * 3600, + connect = dummyPeerConnect net ad + } + Node mgr ch <- ContT $ withNode cfg' + lift . lift $ + f + TestNode + { testMgr = mgr, + testChain = ch, + nodeEvents = sub + } where - cfg = def{R.createIfMissing = True, R.errorIfExists = True} + cfg = def {R.createIfMissing = True, R.errorIfExists = True} cols = [("node", def)] allBlocks :: [Block] allBlocks = - fromRight (error "Could not decode blocks") $ + fromRight (error "Could not decode blocks") $ runGet f (decodeBase64Lenient allBlocksBase64) where f = mapM (const get) [(1 :: Int) .. 15] allBlocksBase64 :: ByteString allBlocksBase64 = - "AAAAIAYibkYRGgtZyq8SYEPrW78ow086XjMqH8eytzzxiJEPakRJalmWTFwdvzNuH8fHLZEjn+4N\ - \FNMANdB7ez2M4a3TFbNe//9/IAMAAAABAgAAAAEAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA\ - \AAAAAP////8MUQEBCC9FQjMyLjAv/////wEA8gUqAQAAACMhAwTspkCjMezKs47BPpafou1jjsHf\ - \1OHjgkqxnwEYkK9zrAAAAAAAAAAge0RDjOrqVayGUoQsbNTJcTXUM+psaHpmuiFy6hwo2T8yn0CL\ - \7WDJw9hxl1kf5c4JySq3WJF8OPsoguzF7mXH3tQVs17//38gAAAAAAECAAAAAQAAAAAAAAAAAAAA\ - \AAAAAAAAAAAAAAAAAAAAAAAAAAAA/////wxSAQEIL0VCMzIuMC//////AQDyBSoBAAAAIyEDBOym\ - \QKMx7MqzjsE+lp+i7WOOwd/U4eOCSrGfARiQr3OsAAAAAAAAACCKlhzDaFkrsmO2FhmeQS9ONS8D\ - \QsU4H97yNxVhyIXYJuG3a9cyQpdeETjCQ6JybgkwI0OOfa4eYazf7WWI5UAk1BWzXv//fyAEAAAA\ - \AQIAAAABAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAD/////DFMBAQgvRUIzMi4wL///\ - \//8BAPIFKgEAAAAjIQME7KZAozHsyrOOwT6Wn6LtY47B39Th44JKsZ8BGJCvc6wAAAAAAAAAIP/S\ - \XiIJZqvUyBY90z72dv6+/GG50R3vc3UAK8AHP89wChmkVP6nefjOt+sNyhbKk9zia47F08oTNtC0\ - \OG1zyuXVFbNe//9/IAEAAAABAgAAAAEAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAP//\ - \//8MVAEBCC9FQjMyLjAv/////wEA8gUqAQAAACMhAwTspkCjMezKs47BPpafou1jjsHf1OHjgkqx\ - \nwEYkK9zrAAAAAAAAAAgeQtE1s3YV/uS2jUouo3S9DJAVf5OGk+Nyx+No1mPH24b5JCkr/tSP0E/\ - \NYVkVcE0ZHxbO/fu5wOd+8VolvPQYtUVs17//38gAAAAAAECAAAAAQAAAAAAAAAAAAAAAAAAAAAA\ - \AAAAAAAAAAAAAAAAAAAA/////wxVAQEIL0VCMzIuMC//////AQDyBSoBAAAAIyEDBOymQKMx7Mqz\ - \jsE+lp+i7WOOwd/U4eOCSrGfARiQr3OsAAAAAAAAACBgtvss8QiesqxISt/1RJkykhGcLe2eCY49\ - \b6CSNe2UMOVYGZ++uRCKvaJ2+jo7akr7XsdXCYSAmuw6DwSO8lvF1RWzXv//fyAAAAAAAQIAAAAB\ - \AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAD/////DFYBAQgvRUIzMi4wL/////8BAPIF\ - \KgEAAAAjIQME7KZAozHsyrOOwT6Wn6LtY47B39Th44JKsZ8BGJCvc6wAAAAAAAAAID92Jp1mAeny\ - \N0dMCWoMyTiBk3sWT5VxzI75ycVflYkMCnXLFhuwrMdBbZmXJinAJBUpN7BV0XvlM2PRmb7HQebV\ - \FbNe//9/IAEAAAABAgAAAAEAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAP////8MVwEB\ - \CC9FQjMyLjAv/////wEA8gUqAQAAACMhAwTspkCjMezKs47BPpafou1jjsHf1OHjgkqxnwEYkK9z\ - \rAAAAAAAAAAgxEgEkhjf5p+ql8dETmdSCdCdk+vB26+V2SGLEuE1+kA1acGCdQoQBqec8P/knItJ\ - \M213OIrDX6U5IB6fgIas7dYVs17//38gAQAAAAECAAAAAQAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA\ - \AAAAAAAAAAAA/////wxYAQEIL0VCMzIuMC//////AQDyBSoBAAAAIyEDBOymQKMx7MqzjsE+lp+i\ - \7WOOwd/U4eOCSrGfARiQr3OsAAAAAAAAACDku4EB5X7htWpHg+aMzzW1AABttpNQTew7K3Aj2fh/\ - \OuOCPhJApmcXq5o42tkksFSuhYvcfqaSHCuuFgjo6ohz1hWzXv//fyAAAAAAAQIAAAABAAAAAAAA\ - \AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAD/////DFkBAQgvRUIzMi4wL/////8BAPIFKgEAAAAj\ - \IQME7KZAozHsyrOOwT6Wn6LtY47B39Th44JKsZ8BGJCvc6wAAAAAAAAAIKWpAhOWbkEN9vWf1uCu\ - \eXtVOZIE9V1OE87iC+H9atBRtY4LPgaWUSVMNh9SeZK1NViIFMklbjsfqYiC4eA/VuLWFbNe//9/\ - \IAAAAAABAgAAAAEAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAP////8MWgEBCC9FQjMy\ - \LjAv/////wEA8gUqAQAAACMhAwTspkCjMezKs47BPpafou1jjsHf1OHjgkqxnwEYkK9zrAAAAAAA\ - \AAAgZ4T81y9DXuJanHjsr8cY5HM6ZvbETRj5dvpViqc1yH0oN9OOruaO5mjdITJwweVCzjSQ5Wsl\ - \vSOKaKvEX5j9l9YVs17//38gAAAAAAECAAAAAQAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA\ - \AAAA/////wxbAQEIL0VCMzIuMC//////AQDyBSoBAAAAIyEDBOymQKMx7MqzjsE+lp+i7WOOwd/U\ - \4eOCSrGfARiQr3OsAAAAAAAAACCV3J2A3qneSJ7Q/RuF8OPd8O1izIXvKElR/xg/+InGNEafu0Ul\ - \3VYJR93zbAQuns9hUfAhA8MTBPk8bbDabDfo1hWzXv//fyAAAAAAAQIAAAABAAAAAAAAAAAAAAAA\ - \AAAAAAAAAAAAAAAAAAAAAAAAAAD/////DFwBAQgvRUIzMi4wL/////8BAPIFKgEAAAAjIQME7KZA\ - \ozHsyrOOwT6Wn6LtY47B39Th44JKsZ8BGJCvc6wAAAAAAAAAINcGedRly1+dXQrcCaZRXTIG2GHV\ - \0tPCGpZtFnvfhuhSx8d3Azdv/MXRJgsb56qqmD5gsXiWUdi7ia7wsBZVylvWFbNe//9/IAEAAAAB\ - \AgAAAAEAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAP////8MXQEBCC9FQjMyLjAv////\ - \/wEA8gUqAQAAACMhAwTspkCjMezKs47BPpafou1jjsHf1OHjgkqxnwEYkK9zrAAAAAAAAAAgDxu3\ - \+7op0n6+s1ZJTqqzjHWH84YorH8hTbLiuYGgNyWIkhaj0zR7Vc+fSRm4UYUaPsefRhq3fUt8glyS\ - \D8P/5tcVs17//38gAwAAAAECAAAAAQAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA////\ - \/wxeAQEIL0VCMzIuMC//////AQDyBSoBAAAAIyEDBOymQKMx7MqzjsE+lp+i7WOOwd/U4eOCSrGf\ - \ARiQr3OsAAAAAAAAACDYVJqsPyQ8MwR+LRafufm1LB97SQoyFJdvKVohBvNyfD4/FxT2i0rlYQcS\ - \TQAvTnehousK2P8T9c0qx4Yj72lT1xWzXv//fyAAAAAAAQIAAAABAAAAAAAAAAAAAAAAAAAAAAAA\ - \AAAAAAAAAAAAAAAAAAD/////DF8BAQgvRUIzMi4wL/////8BAPIFKgEAAAAjIQME7KZAozHsyrOO\ - \wT6Wn6LtY47B39Th44JKsZ8BGJCvc6wAAAAA" + "AAAAIAYibkYRGgtZyq8SYEPrW78ow086XjMqH8eytzzxiJEPakRJalmWTFwdvzNuH8fHLZEjn+4N\ + \FNMANdB7ez2M4a3TFbNe//9/IAMAAAABAgAAAAEAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA\ + \AAAAAP////8MUQEBCC9FQjMyLjAv/////wEA8gUqAQAAACMhAwTspkCjMezKs47BPpafou1jjsHf\ + \1OHjgkqxnwEYkK9zrAAAAAAAAAAge0RDjOrqVayGUoQsbNTJcTXUM+psaHpmuiFy6hwo2T8yn0CL\ + \7WDJw9hxl1kf5c4JySq3WJF8OPsoguzF7mXH3tQVs17//38gAAAAAAECAAAAAQAAAAAAAAAAAAAA\ + \AAAAAAAAAAAAAAAAAAAAAAAAAAAA/////wxSAQEIL0VCMzIuMC//////AQDyBSoBAAAAIyEDBOym\ + \QKMx7MqzjsE+lp+i7WOOwd/U4eOCSrGfARiQr3OsAAAAAAAAACCKlhzDaFkrsmO2FhmeQS9ONS8D\ + \QsU4H97yNxVhyIXYJuG3a9cyQpdeETjCQ6JybgkwI0OOfa4eYazf7WWI5UAk1BWzXv//fyAEAAAA\ + \AQIAAAABAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAD/////DFMBAQgvRUIzMi4wL///\ + \//8BAPIFKgEAAAAjIQME7KZAozHsyrOOwT6Wn6LtY47B39Th44JKsZ8BGJCvc6wAAAAAAAAAIP/S\ + \XiIJZqvUyBY90z72dv6+/GG50R3vc3UAK8AHP89wChmkVP6nefjOt+sNyhbKk9zia47F08oTNtC0\ + \OG1zyuXVFbNe//9/IAEAAAABAgAAAAEAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAP//\ + \//8MVAEBCC9FQjMyLjAv/////wEA8gUqAQAAACMhAwTspkCjMezKs47BPpafou1jjsHf1OHjgkqx\ + \nwEYkK9zrAAAAAAAAAAgeQtE1s3YV/uS2jUouo3S9DJAVf5OGk+Nyx+No1mPH24b5JCkr/tSP0E/\ + \NYVkVcE0ZHxbO/fu5wOd+8VolvPQYtUVs17//38gAAAAAAECAAAAAQAAAAAAAAAAAAAAAAAAAAAA\ + \AAAAAAAAAAAAAAAAAAAA/////wxVAQEIL0VCMzIuMC//////AQDyBSoBAAAAIyEDBOymQKMx7Mqz\ + \jsE+lp+i7WOOwd/U4eOCSrGfARiQr3OsAAAAAAAAACBgtvss8QiesqxISt/1RJkykhGcLe2eCY49\ + \b6CSNe2UMOVYGZ++uRCKvaJ2+jo7akr7XsdXCYSAmuw6DwSO8lvF1RWzXv//fyAAAAAAAQIAAAAB\ + \AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAD/////DFYBAQgvRUIzMi4wL/////8BAPIF\ + \KgEAAAAjIQME7KZAozHsyrOOwT6Wn6LtY47B39Th44JKsZ8BGJCvc6wAAAAAAAAAID92Jp1mAeny\ + \N0dMCWoMyTiBk3sWT5VxzI75ycVflYkMCnXLFhuwrMdBbZmXJinAJBUpN7BV0XvlM2PRmb7HQebV\ + \FbNe//9/IAEAAAABAgAAAAEAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAP////8MVwEB\ + \CC9FQjMyLjAv/////wEA8gUqAQAAACMhAwTspkCjMezKs47BPpafou1jjsHf1OHjgkqxnwEYkK9z\ + \rAAAAAAAAAAgxEgEkhjf5p+ql8dETmdSCdCdk+vB26+V2SGLEuE1+kA1acGCdQoQBqec8P/knItJ\ + \M213OIrDX6U5IB6fgIas7dYVs17//38gAQAAAAECAAAAAQAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA\ + \AAAAAAAAAAAA/////wxYAQEIL0VCMzIuMC//////AQDyBSoBAAAAIyEDBOymQKMx7MqzjsE+lp+i\ + \7WOOwd/U4eOCSrGfARiQr3OsAAAAAAAAACDku4EB5X7htWpHg+aMzzW1AABttpNQTew7K3Aj2fh/\ + \OuOCPhJApmcXq5o42tkksFSuhYvcfqaSHCuuFgjo6ohz1hWzXv//fyAAAAAAAQIAAAABAAAAAAAA\ + \AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAD/////DFkBAQgvRUIzMi4wL/////8BAPIFKgEAAAAj\ + \IQME7KZAozHsyrOOwT6Wn6LtY47B39Th44JKsZ8BGJCvc6wAAAAAAAAAIKWpAhOWbkEN9vWf1uCu\ + \eXtVOZIE9V1OE87iC+H9atBRtY4LPgaWUSVMNh9SeZK1NViIFMklbjsfqYiC4eA/VuLWFbNe//9/\ + \IAAAAAABAgAAAAEAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAP////8MWgEBCC9FQjMy\ + \LjAv/////wEA8gUqAQAAACMhAwTspkCjMezKs47BPpafou1jjsHf1OHjgkqxnwEYkK9zrAAAAAAA\ + \AAAgZ4T81y9DXuJanHjsr8cY5HM6ZvbETRj5dvpViqc1yH0oN9OOruaO5mjdITJwweVCzjSQ5Wsl\ + \vSOKaKvEX5j9l9YVs17//38gAAAAAAECAAAAAQAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA\ + \AAAA/////wxbAQEIL0VCMzIuMC//////AQDyBSoBAAAAIyEDBOymQKMx7MqzjsE+lp+i7WOOwd/U\ + \4eOCSrGfARiQr3OsAAAAAAAAACCV3J2A3qneSJ7Q/RuF8OPd8O1izIXvKElR/xg/+InGNEafu0Ul\ + \3VYJR93zbAQuns9hUfAhA8MTBPk8bbDabDfo1hWzXv//fyAAAAAAAQIAAAABAAAAAAAAAAAAAAAA\ + \AAAAAAAAAAAAAAAAAAAAAAAAAAD/////DFwBAQgvRUIzMi4wL/////8BAPIFKgEAAAAjIQME7KZA\ + \ozHsyrOOwT6Wn6LtY47B39Th44JKsZ8BGJCvc6wAAAAAAAAAINcGedRly1+dXQrcCaZRXTIG2GHV\ + \0tPCGpZtFnvfhuhSx8d3Azdv/MXRJgsb56qqmD5gsXiWUdi7ia7wsBZVylvWFbNe//9/IAEAAAAB\ + \AgAAAAEAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAP////8MXQEBCC9FQjMyLjAv////\ + \/wEA8gUqAQAAACMhAwTspkCjMezKs47BPpafou1jjsHf1OHjgkqxnwEYkK9zrAAAAAAAAAAgDxu3\ + \+7op0n6+s1ZJTqqzjHWH84YorH8hTbLiuYGgNyWIkhaj0zR7Vc+fSRm4UYUaPsefRhq3fUt8glyS\ + \D8P/5tcVs17//38gAwAAAAECAAAAAQAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA////\ + \/wxeAQEIL0VCMzIuMC//////AQDyBSoBAAAAIyEDBOymQKMx7MqzjsE+lp+i7WOOwd/U4eOCSrGf\ + \ARiQr3OsAAAAAAAAACDYVJqsPyQ8MwR+LRafufm1LB97SQoyFJdvKVohBvNyfD4/FxT2i0rlYQcS\ + \TQAvTnehousK2P8T9c0qx4Yj72lT1xWzXv//fyAAAAAAAQIAAAABAAAAAAAAAAAAAAAAAAAAAAAA\ + \AAAAAAAAAAAAAAAAAAD/////DF8BAQgvRUIzMi4wL/////8BAPIFKgEAAAAjIQME7KZAozHsyrOO\ + \wT6Wn6LtY47B39Th44JKsZ8BGJCvc6wAAAAA"