haskoin-node 1.4.4 → 2.0.0

raw patch · 9 files changed

+276/−159 lines, 9 filesdep +fast-loggerdep −monad-loggerPVP ok

version bump matches the API change (PVP)

Dependencies added: fast-logger

Dependencies removed: monad-logger

API changes (from Hackage documentation)

Files

• CHANGELOG.md +7/−0
• haskoin-node.cabal +5/−3
• src/Haskoin/Node.hs +14/−9
• src/Haskoin/Node/Chain.hs +62/−60
• src/Haskoin/Node/Logger.hs +71/−0
• src/Haskoin/Node/Loop.hs +19/−0
• src/Haskoin/Node/Peer.hs +22/−22
• src/Haskoin/Node/PeerMgr.hs +72/−61
• test/Haskoin/NodeSpec.hs +4/−4

@@ -4,6 +4,13 @@ The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/) and this project adheres to [Semantic Versioning](http://semver.org/spec/v2.0.0.html). +## [2.0.0] - 2026-10-31++### Changed++- Replace monad-logger with fast-logger. Configuration records take a `Logger`,+  and functions need only `MonadIO` or `MonadUnliftIO`.+ ## [1.4.4] - 2026-08-31  ### Added

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           haskoin-node-version:        1.4.4+version:        2.0.0 synopsis:       P2P library for Bitcoin and Bitcoin Cash description:    Please see the README on GitHub at <https://github.com/jprupp/haskoin-node#readme> category:       Bitcoin, Finance, Network@@ -29,6 +29,8 @@       Haskoin.Node   other-modules:       Haskoin.Node.Chain+      Haskoin.Node.Logger+      Haskoin.Node.Loop       Haskoin.Node.Peer       Haskoin.Node.PeerMgr       Paths_haskoin_node@@ -43,9 +45,9 @@     , conduit-extra     , containers     , data-default+    , fast-logger     , hashable     , haskoin-core >=1.3.0-    , monad-logger     , mtl     , network     , nqe >=0.6.3@@ -80,11 +82,11 @@     , conduit-extra     , containers     , data-default+    , fast-logger     , hashable     , haskoin-core >=1.3.0     , haskoin-node     , hspec-    , monad-logger     , mtl     , network     , nqe >=0.6.3

@@ -12,6 +12,7 @@   ( module Haskoin.Node.Peer,     module Haskoin.Node.PeerMgr,     module Haskoin.Node.Chain,+    module Haskoin.Node.Logger,     NodeConfig (..),     NodeEvent (..),     Node (..),@@ -20,9 +21,7 @@   ) where -import Control.Monad (forever) import Control.Monad.Cont (ContT (..), MonadCont (callCC), cont, runCont, runContT)-import Control.Monad.Logger import Control.Monad.Trans (lift) import Data.Conduit.Network import Data.String.Conversions (cs)@@ -30,6 +29,8 @@ import Database.RocksDB (ColumnFamily, DB) import Haskoin import Haskoin.Node.Chain+import Haskoin.Node.Logger+import Haskoin.Node.Loop (loopForever) import Haskoin.Node.Peer import Haskoin.Node.PeerMgr import NQE@@ -59,7 +60,9 @@     timeout :: !NominalDiffTime,     -- | peer disconnect after seconds     maxPeerLife :: !NominalDiffTime,-    connect :: !(SockAddr -> WithConnection)+    connect :: !(SockAddr -> WithConnection),+    -- | log messages here+    logger :: !Logger   }  data Node = Node@@ -95,7 +98,7 @@  chainEvents ::   (MonadIO m) => PeerMgr -> Inbox ChainEvent -> Publisher NodeEvent -> m ()-chainEvents mgr input output = forever $ do+chainEvents mgr input output = loopForever $ do   event <- receive input   case event of     ChainBestBlock bb -> peerMgrBest mgr bb.height@@ -103,9 +106,9 @@   publish (ChainEvent event) output  peerEvents ::-  (MonadLoggerIO m) =>+  (MonadIO m) =>   Chain -> PeerMgr -> Inbox PeerEvent -> Publisher NodeEvent -> m ()-peerEvents ch mgr input output = forever $ do+peerEvents ch mgr input output = loopForever $ do   event <- receive input   case event of     PeerConnected p ->@@ -132,14 +135,16 @@  -- | Launch node process in the foreground. withNode ::-  (MonadUnliftIO m, MonadLoggerIO m) => NodeConfig -> (Node -> m a) -> m a+  (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, ..}+  let peerMgrCfg =+        PeerMgrConfig {pub = peerPub, logger = withSource "PeerMgr" logger, ..}+  let chainCfg =+        ChainConfig {pub = chainPub, logger = withSource "Chain" logger, ..}   chain <- ContT (withChain chainCfg)   peerMgr <- ContT $ withPeerMgr peerMgrCfg   link =<< ContT (withAsync $ chainEvents peerMgr chainSub pub)

@@ -11,7 +11,6 @@ {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE NoFieldSelectors #-} {-# OPTIONS_GHC -fno-warn-orphans #-}@@ -36,8 +35,7 @@   ) where -import Control.Monad (forM_, forever, guard, when)-import Control.Monad.Logger+import Control.Monad (forM_, guard, when) import Control.Monad.Trans.Reader import Data.ByteString qualified as B import Data.Function (on)@@ -52,6 +50,8 @@ import Database.RocksDB qualified as R import Database.RocksDB.Query import Haskoin hiding (Key)+import Haskoin.Node.Logger+import Haskoin.Node.Loop (loopForever) import Haskoin.Node.Peer import Haskoin.Node.PeerMgr (myVersion) import NQE@@ -70,7 +70,9 @@     -- | send header chain events here     pub :: !(Publisher ChainEvent),     -- | timeout in seconds-    timeout :: !NominalDiffTime+    timeout :: !NominalDiffTime,+    -- | log messages here+    logger :: !Logger   }  data ChainMessage@@ -189,7 +191,7 @@   addBlockHeaders bns = withReaderT (.config) (addBlockHeaders bns)  withChain ::-  (MonadLoggerIO m, MonadUnliftIO m) => ChainConfig -> (Chain -> m a) -> m a+  (MonadUnliftIO m) => ChainConfig -> (Chain -> m a) -> m a withChain cfg action = do   (inbox, mailbox) <- newMailbox   st <-@@ -208,73 +210,73 @@       withSyncLoop ch.mailbox (run ch inbox)     run ch inbox = do       runReaderT getBestBlockHeader cfg-        >>= chainEvent cfg.pub . ChainBestBlock-      forever $ do-        $(logDebugS) "Chain" "Awaiting event..."+        >>= chainEvent cfg . ChainBestBlock+      loopForever $ do+        logDebug ch.config.logger "Awaiting event..."         msg <- receive inbox         chainConfigMessage ch msg -chainEvent :: (MonadLoggerIO m) => Publisher ChainEvent -> ChainEvent -> m ()-chainEvent pub e = do+chainEvent :: (MonadIO m) => ChainConfig -> ChainEvent -> m ()+chainEvent cfg e = do   case e of     ChainBestBlock b ->-      $(logInfoS)-        "Chain"+      logInfo+        cfg.logger         ("Best block header at height " <> cs (show b.height))     ChainSynced b ->-      $(logInfoS)-        "Chain"+      logInfo+        cfg.logger         ("Headers in sync at height " <> cs (show b.height))-  publish e pub+  publish e cfg.pub -processHeaders :: (MonadLoggerIO m) => Chain -> Peer -> [BlockHeader] -> m ()+processHeaders :: (MonadIO m) => Chain -> Peer -> [BlockHeader] -> m () processHeaders ch p hs = do   let len = length hs-  $(logDebugS)-    "Chain"+  logDebug+    ch.config.logger     ("Processing " <> cs (show len) <> " headers from peer " <> p.label)   let net = ch.config.net   now <- liftIO getCurrentTime   pbest <- runReaderT getBestBlockHeader ch.config   importHeaders ch now hs >>= \case     Nothing -> do-      $(logWarnS)-        "Chain"+      logWarn+        ch.config.logger         ("Could not connect headers from peer " <> p.label)       killPeer p     Just done -> do       setLastReceived ch.state       best <- runReaderT getBestBlockHeader ch.config       when (pbest.header /= best.header) $-        chainEvent ch.config.pub (ChainBestBlock best)+        chainEvent ch.config (ChainBestBlock best)       if done         then do           MSendHeaders `sendMessage` p-          finishPeer ch.state p+          finishPeer ch p           syncNewPeer ch           syncNotif ch         else syncPeer ch p -syncNewPeer :: (MonadLoggerIO m) => Chain -> m ()+syncNewPeer :: (MonadIO m) => Chain -> m () syncNewPeer ch =   getSyncingPeer ch.state >>= \case     Just _ -> return ()     Nothing ->-      nextPeer ch.state >>= \case+      nextPeer ch >>= \case         Nothing -> return ()         Just p -> do-          $(logDebugS) "Chain" ("Syncing against peer " <> p.label)+          logDebug ch.config.logger ("Syncing against peer " <> p.label)           syncPeer ch p -syncNotif :: (MonadLoggerIO m) => Chain -> m ()+syncNotif :: (MonadIO m) => Chain -> m () syncNotif ch =   notifySynced ch >>= \case     False -> return ()     True ->       runReaderT getBestBlockHeader ch.config-        >>= chainEvent ch.config.pub . ChainSynced+        >>= chainEvent ch.config . ChainSynced -syncPeer :: (MonadLoggerIO m) => Chain -> Peer -> m ()+syncPeer :: (MonadIO m) => Chain -> Peer -> m () syncPeer ch p = do   t <- liftIO getCurrentTime   m <-@@ -284,16 +286,16 @@         | otherwise -> return Nothing       Nothing -> syncing_new t   forM_ m $ \g -> do-    $(logDebugS)-      "Chain"+    logDebug+      ch.config.logger       ("Requesting headers from peer " <> p.label)     MGetHeaders g `sendMessage` p   where     syncing_new t =-      setSyncingPeer ch.state p >>= \case+      setSyncingPeer ch p >>= \case         False -> return Nothing         True -> do-          $(logDebugS) "Chain" ("Locked peer " <> p.label)+          logDebug ch.config.logger ("Locked peer " <> p.label)           h <- runReaderT getBestBlockHeader ch.config           Just <$> syncHeaders ch t h p     syncing_me t m = do@@ -302,26 +304,26 @@         Just h -> return h       Just <$> syncHeaders ch t h p -chainConfigMessage :: (MonadLoggerIO m) => Chain -> ChainMessage -> m ()+chainConfigMessage :: (MonadIO m) => Chain -> ChainMessage -> m () chainConfigMessage ch (ChainHeaders p hs) =   processHeaders ch p hs chainConfigMessage ch (ChainPeerConnected p) = do-  $(logDebugS) "Chain" ("Connected peer " <> p.label)+  logDebug ch.config.logger ("Connected peer " <> p.label)   addPeer ch.state p   syncNewPeer ch chainConfigMessage ch (ChainPeerDisconnected p) = do-  $(logDebugS) "Chain" ("Disconnected peer " <> p.label)-  finishPeer ch.state p+  logDebug ch.config.logger ("Disconnected peer " <> p.label)+  finishPeer ch p   syncNewPeer ch chainConfigMessage ch ChainPing = do-  $(logDebugS) "Chain" "Internal clock event"+  logDebug ch.config.logger "Internal clock event"   let to = ch.config.timeout   now <- liftIO getCurrentTime   chainSyncingPeer ch.state >>= \case     Just ChainSync {peer = p, timestamp = t}       | now `diffUTCTime` t > to -> do-          $(logWarnS)-            "Chain"+          logWarn+            ch.config.logger             ("Syncing peer " <> p.label <> " timed out")           killPeer p       | otherwise -> return ()@@ -332,7 +334,7 @@   withAsync go $ \a ->     link a >> mf   where-    go = forever $ do+    go = loopForever $ do       delay <- randomRIO (2 * 10 ^ 6, 2 * 10 ^ 7)       threadDelay delay       ChainPing `send` mbox@@ -381,11 +383,11 @@ -- headers is less than 2000, which means that there are no more headers to sync -- from the peer that delivered these. importHeaders ::-  (MonadLoggerIO m) => Chain -> UTCTime -> [BlockHeader] -> m (Maybe Bool)+  (MonadIO m) => Chain -> UTCTime -> [BlockHeader] -> m (Maybe Bool) importHeaders ch now hs =   connect >>= \case     Left e -> do-      $(logErrorS) "Chain" ("connectBlocks: " <> cs e)+      logError ch.config.logger ("connectBlocks: " <> cs e)       return Nothing     Right bns       | null bns -> return (Just False)@@ -426,12 +428,12 @@       posixSecondsToUTCTime . fromIntegral . (.header.timestamp)  -- | Get next peer to sync against from the queue.-nextPeer :: (MonadLoggerIO m) => TVar ChainState -> m (Maybe Peer)-nextPeer st = fmap (.peers) (readTVarIO st) >>= go+nextPeer :: (MonadIO m) => Chain -> m (Maybe Peer)+nextPeer ch = fmap (.peers) (readTVarIO ch.state) >>= go   where     go [] = return Nothing     go (p : ps) =-      setSyncingPeer st p >>= \case+      setSyncingPeer ch p >>= \case         True -> return (Just p)         False -> go ps @@ -481,23 +483,23 @@     ChainState {syncing = Just ChainSync {peer}} -> return (Just peer)     _ -> return Nothing -setSyncingPeer :: (MonadLoggerIO m) => TVar ChainState -> Peer -> m Bool-setSyncingPeer st p =+setSyncingPeer :: (MonadIO m) => Chain -> Peer -> m Bool+setSyncingPeer ch p =   setBusy p >>= \case     False -> do-      $(logDebugS)-        "Chain"+      logDebug+        ch.config.logger         ("Could not lock peer: " <> p.label)       return False     True -> do-      $(logDebugS) "Chain" $+      logDebug ch.config.logger $         ("Locked peer: " <> p.label)       set_it       return True   where     set_it = do       now <- liftIO getCurrentTime-      atomically $ modifyTVar st $ \s ->+      atomically $ modifyTVar ch.state $ \s ->         s           { syncing =               Just@@ -510,22 +512,22 @@  -- | Remove a peer from the queue of peers to sync and unset the syncing peer if -- it is set to the provided peer.-finishPeer :: (MonadLoggerIO m) => TVar ChainState -> Peer -> m ()-finishPeer st p =+finishPeer :: (MonadIO m) => Chain -> Peer -> m ()+finishPeer ch p =   remove_peer >>= \case     False ->-      $(logDebugS)-        "Chain"+      logDebug+        ch.config.logger         ("Removed peer " <> p.label <> " from queue")     True -> do-      $(logDebugS)-        "Chain"+      logDebug+        ch.config.logger         ("Releasing syncing peer " <> p.label)       setFree p   where     remove_peer =       atomically $-        readTVar st >>= \s -> case s.syncing of+        readTVar ch.state >>= \s -> case s.syncing of           Just ChainSync {peer = p'}             | p == p' -> do                 unset_syncing@@ -534,10 +536,10 @@             remove_from_queue             return False     unset_syncing =-      modifyTVar st $ \x ->+      modifyTVar ch.state $ \x ->         x {syncing = Nothing}     remove_from_queue =-      modifyTVar st $ \x ->+      modifyTVar ch.state $ \x ->         x {peers = delete p x.peers}  -- | Return syncing peer data.

@@ -0,0 +1,71 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoFieldSelectors #-}++-- | Logging to standard error. A 'Logger' is a plain value carried in+-- configuration records, so code that logs only needs 'MonadIO'.+module Haskoin.Node.Logger+  ( Logger (..),+    LogLevel (..),+    withLogger,+    withSource,+    logAt,+    logDebug,+    logInfo,+    logWarn,+    logError,+  )+where++import Control.Monad (when)+import Data.Text (Text)+import Data.Text qualified as T+import System.Log.FastLogger+  ( LogStr,+    LogType' (LogStderr),+    defaultBufSize,+    newFastLogger1,+    toLogStr,+  )+import UnliftIO (MonadIO, bracket, liftIO)++data LogLevel = LevelDebug | LevelInfo | LevelWarn | LevelError+  deriving (Eq, Ord, Show)++data Logger = Logger+  { -- | messages below this level are dropped+    level :: !LogLevel,+    -- | tag printed with every message+    source :: !Text,+    -- | write one formatted line+    push :: !(LogStr -> IO ())+  }++-- | Log to standard error in the order messages are logged. Buffered lines are+-- written out when the action returns or throws.+withLogger :: LogLevel -> (Logger -> IO a) -> IO a+withLogger level go =+  bracket (newFastLogger1 (LogStderr defaultBufSize)) snd $ \(push, _) ->+    go Logger {level, source = "", push}++-- | Same output with a different tag.+withSource :: Text -> Logger -> Logger+withSource source logger = logger {source}++-- | Lines look like monad-logger's: @[Info#Chain] message@.+logAt :: (MonadIO m) => LogLevel -> Logger -> Text -> m ()+logAt l logger msg =+  when (l >= logger.level) . liftIO . logger.push $+    "[" <> toLogStr (drop 5 (show l)) <> tag <> "] " <> toLogStr msg <> "\n"+  where+    tag+      | T.null logger.source = ""+      | otherwise = "#" <> toLogStr logger.source++logDebug, logInfo, logWarn, logError :: (MonadIO m) => Logger -> Text -> m ()+logDebug = logAt LevelDebug+logInfo = logAt LevelInfo+logWarn = logAt LevelWarn+logError = logAt LevelError

@@ -0,0 +1,19 @@+-- | A replacement for 'Control.Monad.forever' that stays a flat loop in any+-- monad.+--+-- @forever a = let a' = a *> a' in a'@ relies on @*>@ being a tail call. When+-- the monad is only known through a dictionary (a function polymorphic in+-- @m@ that GHC did not specialise), @*>@ is whatever the instance defines.+-- monad-logger's @LoggingT@ leaves it at the default @(id <$ a) <*> b@, and+-- @ReaderT@ defines @>>@ as @*>@, so every iteration leaves an @<*>@+-- continuation frame and two thunks behind for the lifetime of the loop.+--+-- This version sequences with @>>=@ only, which is a tail call in all these+-- stacks, so it never accumulates.+module Haskoin.Node.Loop (loopForever) where++loopForever :: (Monad m) => m a -> m b+loopForever action = go+  where+    go = action >>= \_ -> go+{-# INLINE loopForever #-}

@@ -8,7 +8,6 @@ {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE NoFieldSelectors #-} @@ -35,7 +34,6 @@ import Conduit import Control.Exception import Control.Monad-import Control.Monad.Logger import Control.Monad.Trans.Maybe import Data.Bool (bool) import Data.ByteString (ByteString)@@ -48,6 +46,7 @@ import Data.Text (Text) import Data.Word (Word32) import Haskoin+import Haskoin.Node.Logger import NQE import System.Random import UnliftIO@@ -63,7 +62,8 @@   { pub :: !(Publisher PeerEvent),     net :: !Network,     label :: !Text,-    connect :: !WithConnection+    connect :: !WithConnection,+    logger :: !Logger   }  data PeerEvent@@ -106,17 +106,17 @@  -- | Run peer process in current thread. peer ::-  (MonadLoggerIO m, MonadUnliftIO m) =>+  (MonadUnliftIO m) =>   PeerConfig ->   TVar Bool ->   Inbox PeerMessage ->   m ()-peer cfg@PeerConfig {label, net, connect, pub} busy inbox = do+peer cfg@PeerConfig {label, net, connect, pub, logger} busy inbox = do   let p = wrapPeer cfg busy (inboxToMailbox inbox)   withRunInIO $ \run -> connect (run . peer_session p)   where     go = do-      $(logDebugS) "Peer " $ label <> " awaiting event..."+      logDebug logger $ label <> " awaiting event..."       msg <- receive inbox       dispatchMessage cfg msg >>= bool (return ()) go     peer_session p ad = do@@ -135,51 +135,51 @@  -- | Internal function to dispatch peer messages. dispatchMessage ::-  (MonadLoggerIO m) =>+  (MonadIO m) =>   PeerConfig ->   PeerMessage ->   ConduitT i Message m Bool-dispatchMessage PeerConfig {label} (SendMessage msg) = do-  $(logDebugS) "Peer" (label <> " sending: " <> cs (show msg))+dispatchMessage PeerConfig {label, logger} (SendMessage msg) = do+  logDebug logger (label <> " sending: " <> cs (show msg))   yield msg   return True-dispatchMessage PeerConfig {label} KillPeer = do-  $(logInfoS) "Peer" (label <> " disconnecting")+dispatchMessage PeerConfig {label, logger} KillPeer = do+  logInfo logger (label <> " disconnecting")   return False  -- | Internal conduit to parse messages coming from peer. inPeerConduit ::-  (MonadLoggerIO m) => PeerConfig -> ConduitT ByteString Message m ()-inPeerConduit pc@PeerConfig {label, net} = forever $ do-  $(logDebugS) "Peer" (label <> " awaiting message...")+  (MonadIO m) => PeerConfig -> ConduitT ByteString Message m ()+inPeerConduit pc@PeerConfig {label, net, logger} = forever $ do+  logDebug logger (label <> " awaiting message...")   x <- takeCE 24 .| foldC   when (B.null x) $ do-    $(logErrorS) "Peer" (label <> " sent empty message header")+    logError logger (label <> " sent empty message header")     error "Peer sent empty message header"   case decode x of     Left e -> do-      $(logErrorS) "Peer" (label <> " sent invalid message header")+      logError logger (label <> " sent invalid message header")       error "Peer sent invalid message header"     Right (MessageHeader _ cmd len _)       | len > 32 * 2 ^ (20 :: Int) ->-          $(logWarnS) "Peer" $+          logWarn logger $             label               <> " wants to send "               <> cs (show len)               <> " bytes (too large) for cmd "               <> cs (show cmd)       | otherwise -> do-          $(logDebugS) "Peer" (label <> " sent cmd " <> cs (show cmd))+          logDebug logger (label <> " sent cmd " <> cs (show cmd))           y <- takeCE (fromIntegral len) .| foldC           case runGet (getMessage net) $ x `B.append` y of             Left e -> do-              $(logErrorS)-                "Peer"+              logError+                logger                 (label <> " sent invalid payload for cmd " <> cs (show cmd))               error "Peer sent invalid payload"             Right msg -> do-              $(logDebugS)-                "Peer"+              logDebug+                logger                 (label <> " sent payload for cmd " <> cs (show cmd))               yield msg 

@@ -8,7 +8,6 @@ {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE NoFieldSelectors #-} @@ -37,7 +36,6 @@ import Control.Applicative ((<|>)) import Control.Arrow import Control.Monad-import Control.Monad.Logger import Data.Bits ((.&.)) import Data.Function (on) import Data.List (dropWhileEnd, elemIndex, find, nub, sort)@@ -49,6 +47,8 @@ import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) import Data.Word (Word32, Word64) import Haskoin+import Haskoin.Node.Logger+import Haskoin.Node.Loop (loopForever) import Haskoin.Node.Peer import NQE import Network.Socket@@ -65,7 +65,8 @@     pub :: !(Publisher PeerEvent),     timeout :: !NominalDiffTime,     maxPeerLife :: !NominalDiffTime,-    connect :: !(SockAddr -> WithConnection)+    connect :: !(SockAddr -> WithConnection),+    logger :: !Logger   }  data PeerMgr = PeerMgr@@ -114,7 +115,7 @@       f OnlinePeer {pings = pings} = fromMaybe 60 (median pings)  withPeerMgr ::-  (MonadLoggerIO m, MonadUnliftIO m) =>+  (MonadUnliftIO m) =>   PeerMgrConfig ->   (PeerMgr -> m a) ->   m a@@ -140,14 +141,14 @@       withConnectLoop mgr (link a >> action mgr)  peerManager ::-  (MonadLoggerIO m, MonadUnliftIO m) => PeerMgr -> Inbox PeerMgrMessage -> m ()+  (MonadUnliftIO m) => PeerMgr -> Inbox PeerMgrMessage -> m () peerManager mgr ibx = do-  $(logDebugS) "PeerMgr" "Getting best block..."+  logDebug mgr.config.logger "Getting best block..."   putBestBlock mgr <=< receiveMatch ibx $ \case     ManagerBest b -> Just b     _ -> Nothing-  forever $ do-    $(logDebugS) "PeerMgr" "Awaiting event..."+  loopForever $ do+    logDebug mgr.config.logger "Awaiting event..."     dispatch mgr =<< receive ibx  putBestBlock :: (MonadIO m) => PeerMgr -> BlockHeight -> m ()@@ -177,12 +178,12 @@         <$> mapM (liftIO . toSockAddr mgr.config.net) mgr.config.net.seeds     mapM_ (newPeer mgr) ss -logConnectedPeers :: (MonadLoggerIO m) => PeerMgr -> m ()+logConnectedPeers :: (MonadIO m) => PeerMgr -> m () logConnectedPeers mgr = do   let m = mgr.config.maxPeers   l <- length <$> getConnectedPeers mgr-  $(logInfoS)-    "PeerMgr"+  logInfo+    mgr.config.logger     ("Peers connected: " <> cs (show l) <> "/" <> cs (show m))  getOnlinePeers :: (MonadIO m) => PeerMgr -> m [OnlinePeer]@@ -195,73 +196,73 @@ managerEvent mgr e = publish e mgr.config.pub  dispatch ::-  (MonadLoggerIO m, MonadUnliftIO m) => PeerMgr -> PeerMgrMessage -> m ()+  (MonadUnliftIO m) => PeerMgr -> PeerMgrMessage -> m () dispatch mgr (PeerVersion p v) = do-  $(logDebugS)-    "PeerMgr"+  logDebug+    mgr.config.logger     ("Received peer " <> p.label <> " version " <> cs (show v))   let b = mgr.peers   atomically (setPeerVersion b p v) >>= \case     Just o -> do       when o.online (announcePeer mgr p)-      $(logDebugS)-        "PeerMgr"+      logDebug+        mgr.config.logger         ("Sending version ack to peer " <> p.label)       MVerAck `sendMessage` p     Nothing -> do-      $(logWarnS)-        "PeerMgr"+      logWarn+        mgr.config.logger         ("Version rejected for peer " <> p.label)       killPeer p dispatch mgr (PeerVerAck p) = do   atomically (setPeerVerAck mgr.peers p) >>= \case     Just o -> do-      $(logDebugS) "PeerMgr" ("Received version ack from peer " <> p.label)+      logDebug mgr.config.logger ("Received version ack from peer " <> p.label)       when o.online (announcePeer mgr p)     Nothing -> do-      $(logWarnS)-        "PeerMgr"+      logWarn+        mgr.config.logger         ("Received verack from unknown peer " <> p.label)       killPeer p dispatch mgr (PeerAddrs p nas)   | mgr.config.discover = do       let sas = map (hostToSockAddr . (.address)) nas           len = length sas-      $(logDebugS)-        "PeerMgr"+      logDebug+        mgr.config.logger         ("Received " <> cs (show len) <> " addresses from peer " <> p.label)       forM_ sas (newPeer mgr)   | otherwise =-      $(logDebugS) "PeerMgr" ("Ignoring addresses from peer " <> p.label)+      logDebug mgr.config.logger ("Ignoring addresses from peer " <> p.label) dispatch mgr (PeerPong p n) = do-  $(logDebugS)-    "PeerMgr"+  logDebug+    mgr.config.logger     ("Received pong " <> cs (show n) <> " from peer " <> p.label)   now <- liftIO getCurrentTime   atomically (gotPong mgr.peers n now p)-dispatch _mgr (PeerPing p n) = do-  $(logDebugS)-    "PeerMgr"+dispatch mgr (PeerPing p n) = do+  logDebug+    mgr.config.logger     ("Responding to ping " <> cs (show n) <> " from peer " <> p.label)   MPong (Pong n) `sendMessage` p dispatch mgr (ManagerBest h) = do-  $(logDebugS) "PeerMgr" ("Setting best block to " <> cs (show h))+  logDebug mgr.config.logger ("Setting best block to " <> cs (show h))   putBestBlock mgr h dispatch mgr (Connect sa) = do   connectPeer mgr sa dispatch mgr (PeerDied a) = do   processPeerOffline mgr a dispatch mgr (CheckPeer p) = do-  $(logDebugS) "PeerMgr" ("Housekeeping for peer " <> p.label)+  logDebug mgr.config.logger ("Housekeeping for peer " <> p.label)   checkPeer mgr p -ticklePeer :: (MonadLoggerIO m) => PeerMgr -> Peer -> m ()-ticklePeer m p = do-  $(logDebugS) "PeerMgr" ("Tickling peer " <> p.label)+ticklePeer :: (MonadIO m) => PeerMgr -> Peer -> m ()+ticklePeer mgr p = do+  logDebug mgr.config.logger ("Tickling peer " <> p.label)   t <- liftIO getCurrentTime-  atomically (modifyPeer m.peers p (\o -> o {tickled = t}))+  atomically (modifyPeer mgr.peers p (\o -> o {tickled = t})) -checkPeer :: (MonadLoggerIO m) => PeerMgr -> Peer -> m ()+checkPeer :: (MonadIO m) => PeerMgr -> Peer -> m () checkPeer mgr p =   atomically (mgr.peers `findPeer` p) >>= \case     Just o -> do@@ -270,64 +271,64 @@       let deadline = mgr.config.timeout `addUTCTime` o.tickled       if         | now > expired -> do-            $(logErrorS) "PeerMgr" ("Peer " <> p.label <> " is too old")+            logError mgr.config.logger ("Peer " <> p.label <> " is too old")             killPeer p         | now > deadline -> do-            $(logErrorS) "PeerMgr" ("Peer " <> p.label <> " timed out")+            logError mgr.config.logger ("Peer " <> p.label <> " timed out")             killPeer p         | isNothing o.ping -> sendPing mgr p         | otherwise -> return ()     Nothing -> do-      $(logErrorS) "PeerMgr" ("Peer " <> p.label <> " is offline")+      logError mgr.config.logger ("Peer " <> p.label <> " is offline") -sendPing :: (MonadLoggerIO m) => PeerMgr -> Peer -> m ()+sendPing :: (MonadIO m) => PeerMgr -> Peer -> m () sendPing mgr p = do   atomically (mgr.peers `findPeer` p) >>= \case     Nothing ->-      $(logWarnS) "PeerMgr" ("Will not ping unknown peer " <> p.label)+      logWarn mgr.config.logger ("Will not ping unknown peer " <> p.label)     Just o       | o.online -> do           n <- randomIO           now <- liftIO getCurrentTime           atomically (setPeerPing mgr.peers n now p)-          $(logDebugS)-            "PeerMgr"+          logDebug+            mgr.config.logger             ("Sending ping " <> cs (show n) <> " to peer " <> p.label)           MPing (Ping n) `sendMessage` p       | otherwise ->-          $(logDebugS)-            "PeerMgr"+          logDebug+            mgr.config.logger             ("Will not ping offline peer " <> p.label) -processPeerOffline :: (MonadLoggerIO m) => PeerMgr -> Child -> m ()+processPeerOffline :: (MonadIO m) => PeerMgr -> Child -> m () processPeerOffline mgr a = do   atomically (findPeerAsync mgr.peers a) >>= \case-    Nothing -> $(logErrorS) "PeerMgr" "Disconnected unknown peer"+    Nothing -> logError mgr.config.logger "Disconnected unknown peer"     Just o -> do       if o.online         then do-          $(logErrorS)-            "PeerMgr"+          logError+            mgr.config.logger             ("Disconnected peer " <> o.mailbox.label)           managerEvent mgr (PeerDisconnected o.mailbox)         else-          $(logErrorS)-            "PeerMgr"+          logError+            mgr.config.logger             ("Could not connect to peer " <> o.mailbox.label)       atomically (removePeer mgr.peers o.mailbox)       logConnectedPeers mgr -announcePeer :: (MonadLoggerIO m) => PeerMgr -> Peer -> m ()+announcePeer :: (MonadIO m) => PeerMgr -> Peer -> m () announcePeer mgr p = do   atomically (findPeer mgr.peers p) >>= \case     Just OnlinePeer {online = True} -> do-      $(logInfoS) "PeerMgr" ("Connected to peer " <> p.label)+      logInfo mgr.config.logger ("Connected to peer " <> p.label)       managerEvent mgr (PeerConnected p)       logConnectedPeers mgr     Just OnlinePeer {online = False} ->       return ()     Nothing ->-      $(logWarnS) "PeerMgr" ("Not announcing disconnected peer " <> p.label)+      logWarn mgr.config.logger ("Not announcing disconnected peer " <> p.label)  getNewPeer :: (MonadIO m) => PeerMgr -> m (Maybe SockAddr) getNewPeer mgr =@@ -341,13 +342,13 @@           mgr.addresses           (first (listToMaybe . Set.elems) . Set.splitAt 1) -connectPeer :: (MonadUnliftIO m, MonadLoggerIO m) => PeerMgr -> SockAddr -> m ()+connectPeer :: (MonadUnliftIO m) => PeerMgr -> SockAddr -> m () connectPeer mgr sa = do   atomically (findPeerAddress mgr.peers sa) >>= \case     Just _ ->-      $(logWarnS) "PeerMgr" ("Duplicate connection to peer " <> cs (show sa))+      logWarn mgr.config.logger ("Duplicate connection to peer " <> cs (show sa))     Nothing -> do-      $(logInfoS) "PeerMgr" ("Connecting to peer " <> cs (show sa))+      logInfo mgr.config.logger ("Connecting to peer " <> cs (show sa))       nonce <- randomIO       bb <- getBestBlock mgr       now <- liftIO getCurrentTime@@ -361,7 +362,8 @@               { pub = mgr.config.pub,                 net = mgr.config.net,                 label = text,-                connect = mgr.config.connect sa+                connect = mgr.config.connect sa,+                logger = withSource "Peer" mgr.config.logger               }       busy <- newTVarIO False       let p = wrapPeer pc busy mailbox@@ -393,7 +395,7 @@  withPeerLoop :: (MonadUnliftIO m) => PeerMgr -> Peer -> (Async a -> m a) -> m a withPeerLoop mgr p =-  withAsync . forever $ do+  withAsync . loopForever $ do     let timeout = mgr.config.timeout         ms = floor (timeout * 1000 * 1000)     r <- randomRIO (ms `div` 4, ms `div` 2)@@ -404,19 +406,28 @@ withConnectLoop mgr act =   withAsync go $ \a -> link a >> act   where-    go = forever $ do+    go = loopForever $ do       l <- length <$> getOnlinePeers mgr       when         (l < mgr.config.maxPeers)         (getNewPeer mgr >>= mapM_ (managerConnect mgr))       threadDelay =<< randomRIO (10 ^ 5, 5 * 10 ^ 6) +-- | Upper bound on addresses remembered for future connections. Peers keep+-- relaying addresses for as long as the node runs, and with every connection+-- slot in use nothing ever removes them, so the pool must be bounded.+maxKnownAddresses :: Int+maxKnownAddresses = 4096+ newPeer :: (MonadIO m) => PeerMgr -> SockAddr -> m () newPeer mgr sa =   atomically $     findPeerAddress mgr.peers sa >>= \case       Just _ -> return ()-      Nothing -> modifyTVar mgr.addresses $ Set.insert sa+      Nothing -> modifyTVar' mgr.addresses $ \known ->+        if Set.size known >= maxKnownAddresses+          then known+          else Set.insert sa known  gotPong :: TVar [OnlinePeer] -> Word64 -> UTCTime -> Peer -> STM () gotPong b nonce now p =

@@ -13,7 +13,6 @@ import Conduit import Control.Monad (forM_, forever, replicateM) import Control.Monad.Cont-import Control.Monad.Logger import Control.Monad.Trans (lift) import Data.ByteString (ByteString) import Data.ByteString qualified as B@@ -189,7 +188,7 @@ withTestNode ::   (MonadUnliftIO m) =>   Network -> String -> (TestNode -> m a) -> m a-withTestNode net str f = runNoLoggingT $ flip runContT return $ do+withTestNode net str f = flip runContT return $ do   w <- ContT $ withSystemTempDirectory ("haskoin-node-test-" <> str <> "-")   pub <- ContT withPublisher   sub <- ContT $ withSubscription pub@@ -214,10 +213,11 @@             pub = pub,             timeout = 120,             maxPeerLife = 48 * 3600,-            connect = dummyPeerConnect net ad+            connect = dummyPeerConnect net ad,+            logger = Logger {level = LevelError, source = "", push = \_ -> return ()}           }   Node mgr ch <- ContT $ withNode cfg'-  lift . lift $+  lift $     f       TestNode         { testMgr = mgr,