diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -4,6 +4,11 @@ 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.9.20 +### Changed +- Better log messages. +- Less verbose debug logging. + ## 0.9.19 ### Changed - Better log messages. diff --git a/haskoin-node.cabal b/haskoin-node.cabal --- a/haskoin-node.cabal +++ b/haskoin-node.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 917e10b5d9a35cb85510666d9e1af2a97ae9b7390c2456c2cb141f7fdda4c10d +-- hash: 3105ca1d000db59e33f68ffd6a2ed2990da90f79557b1a3f38798d486912a3b9 name: haskoin-node -version: 0.9.19 +version: 0.9.20 synopsis: Haskoin Node P2P library for Bitcoin and Bitcoin Cash description: Bitcoin and Bitcoin Cash peer-to-peer protocol library featuring headers-first synchronisation. category: Bitcoin, Finance, Network diff --git a/src/Network/Haskoin/Node/Chain.hs b/src/Network/Haskoin/Node/Chain.hs --- a/src/Network/Haskoin/Node/Chain.hs +++ b/src/Network/Haskoin/Node/Chain.hs @@ -24,8 +24,8 @@ import Control.Monad (forever, guard, void, when) import Control.Monad.Except (runExceptT, throwError) -import Control.Monad.Logger (MonadLoggerIO, logDebugS, - logErrorS, logInfoS, logWarnS) +import Control.Monad.Logger (MonadLoggerIO, logErrorS, + logInfoS) import Control.Monad.Reader (MonadReader, asks, runReaderT) import Control.Monad.Trans (lift) import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) @@ -45,8 +45,7 @@ import Haskoin (BlockHash, BlockHeader (..), BlockHeaders (..), BlockNode (..), GetHeaders (..), Message (..), - Network, Timestamp, - blockHashToHex, blockLocator, + Network, Timestamp, blockLocator, connectBlocks, genesisNode, getAncestor, headerHash, splitPoint) @@ -77,11 +76,7 @@ chain cfg inbox = do st <- newTVarIO - ChainState - { chainSyncing = Nothing - , mySynced = False - , newPeers = [] - } + ChainState {chainSyncing = Nothing, mySynced = False, newPeers = []} let rd = ChainReader {myReader = cfg, myChainDB = db, chainState = st} withSyncLoop ch $ run `runReaderT` rd where @@ -89,13 +84,9 @@ db = chainConfDB cfg ch = inboxToMailbox inbox run = do - $(logDebugS) "Chain" "Initializing" initChainDB net getBestBlockHeader >>= chainEvent . ChainBestBlock - $(logInfoS) "Chain" "Initialization complete" - forever $ do - $(logDebugS) "Chain" "Awaiting message" - receive inbox >>= chainMessage + forever (receive inbox >>= chainMessage) chainEvent :: MonadChain m => ChainEvent -> m () chainEvent e = do @@ -103,10 +94,10 @@ case e of ChainBestBlock b -> $(logInfoS) "Chain" $ - "Best block header at height " <> cs (show (nodeHeight b)) + "Best block header at height: " <> cs (show (nodeHeight b)) ChainSynced b -> $(logInfoS) "Chain" $ - "Headers now synced at height " <> cs (show (nodeHeight b)) + "Headers now in sync at height: " <> cs (show (nodeHeight b)) atomically $ l e processHeaders :: @@ -114,7 +105,7 @@ processHeaders p hs = void . runMaybeT $ do net <- chainConfNetwork <$> asks myReader - $(logDebugS) "Chain" $ + $(logInfoS) "Chain" $ "Importing " <> cs (show (length hs)) <> " headers" now <- round <$> liftIO getPOSIXTime pbest <- getBestBlockHeader @@ -129,29 +120,21 @@ ChainBestBlock best if done then do - $(logDebugS) - "Chain" - "Finished importing headers from syncing peer" MSendHeaders `sendMessage` p finishPeer p syncNewPeer syncNotif else do - $(logDebugS) - "Chain" - "Continuing importing headers from syncing peer" syncPeer p syncNewPeer :: MonadChain m => m () syncNewPeer = getSyncingPeer >>= \case Nothing -> do - $(logDebugS) "Chain" "Getting next peer to sync from" nextPeer >>= \case - Nothing -> - $(logDebugS) "Chain" "Finished syncing against all peers" + Nothing -> return () Just p -> syncPeer p - Just _ -> $(logDebugS) "Chain" "Already syncing against a peer" + Just _ -> return () syncNotif :: MonadChain m => m () syncNotif = @@ -160,7 +143,6 @@ syncPeer :: MonadChain m => Peer -> m () syncPeer p = do - $(logDebugS) "Chain" "Syncing headers against selected peer" bb <- chainSyncingPeer >>= \case Just ChainSync {chainSyncPeer = p', chainHighest = Just g} @@ -168,72 +150,30 @@ _ -> getBestBlockHeader now <- round <$> liftIO getPOSIXTime gh <- syncHeaders now bb p - $(logDebugS) "Chain" $ - "Requesting headers from syncing peer for chain head at height: " <> - cs (show (nodeHeight bb)) MGetHeaders gh `sendMessage` p chainMessage :: MonadChain m => ChainMessage -> m () -chainMessage (ChainGetBest reply) = do - $(logDebugS) "Chain" "Responding to request for best block header" - getBestBlockHeader >>= \bh -> do - $(logDebugS) "Chain" $ - "Best block header: " <> blockHashToHex (headerHash (nodeHeader bh)) <> - " at height " <> - cs (show (nodeHeight bh)) - atomically $ reply bh -chainMessage (ChainHeaders p hs) = do - $(logDebugS) "Chain" $ "Processing " <> cs (show (length hs)) <> " headers" - processHeaders p hs -chainMessage (ChainPeerConnected p a) = do - $(logDebugS) "Chain" $ "Adding new peer to sync queue: " <> cs (show a) +chainMessage (ChainGetBest reply) = getBestBlockHeader >>= atomically . reply +chainMessage (ChainHeaders p hs) = processHeaders p hs +chainMessage (ChainPeerConnected p _) = do addPeer p syncNewPeer -chainMessage (ChainPeerDisconnected p a) = do - $(logWarnS) "Chain" $ "Removing a peer from sync queue: " <> cs (show a) +chainMessage (ChainPeerDisconnected p _) = do finishPeer p syncNewPeer chainMessage (ChainGetAncestor h n reply) = do - $(logDebugS) "Chain" $ - "Responding to request for ancestor at height " <> cs (show h) <> - " to block: " <> - blockHashToHex (headerHash (nodeHeader n)) a <- getAncestor h n atomically $ reply a - case a of - Just b -> - $(logDebugS) "Chain" $ - "Ancestor is: " <> blockHashToHex (headerHash (nodeHeader b)) - Nothing -> $(logDebugS) "Chain" "Ancestor not found" chainMessage (ChainGetSplit l r reply) = do - $(logDebugS) "Chain" $ - "Responding to request for split point between blocks " <> - blockHashToHex (headerHash (nodeHeader l)) <> - " & " <> - blockHashToHex (headerHash (nodeHeader r)) s <- splitPoint l r atomically $ reply s - $(logDebugS) "Chain" $ - "Split block is: " <> blockHashToHex (headerHash (nodeHeader s)) chainMessage (ChainGetBlock h reply) = do - $(logDebugS) "Chain" $ - "Responding to request for block: " <> blockHashToHex h m <- getBlockHeader h atomically $ reply m - case m of - Nothing -> - $(logDebugS) "Chain" $ "Block not found: " <> blockHashToHex h - Just b -> - $(logDebugS) "Chain" $ - "Block found at height " <> cs (show (nodeHeight b)) chainMessage (ChainIsSynced reply) = do s <- isSynced - if s - then $(logDebugS) "Chain" "Chain is in sync" - else $(logDebugS) "Chain" "Chain is NOT in sync" atomically $ reply s chainMessage ChainPing = do - $(logDebugS) "Chain" "Housekeeping..." ChainConfig {chainConfTimeout = to} <- asks myReader now <- round <$> liftIO getPOSIXTime chainSyncingPeer >>= \case @@ -251,9 +191,6 @@ forever $ do threadDelay =<< liftIO (randomRIO (2 * 1000 * 1000, 20 * 1000 * 1000)) - $(logDebugS) - "ChainSyncLoop" - "Ping chain for housekeeping" ChainPing `send` ch -- | Version of the database. diff --git a/src/Network/Haskoin/Node/Manager.hs b/src/Network/Haskoin/Node/Manager.hs --- a/src/Network/Haskoin/Node/Manager.hs +++ b/src/Network/Haskoin/Node/Manager.hs @@ -25,8 +25,7 @@ import Control.Monad.Except (ExceptT (..), runExceptT, throwError) import Control.Monad.Logger (MonadLogger, MonadLoggerIO, - logDebugS, logErrorS, logInfoS, - logWarnS) + logErrorS, logInfoS, logWarnS) import Control.Monad.Reader (MonadReader, asks, runReaderT) import Control.Monad.Trans (lift) import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) @@ -44,10 +43,9 @@ import Haskoin (Addr (..), BlockHeight, Message (..), Network (..), NetworkAddress (..), Ping (..), - Pong (..), VarString (..), - Version (..), commandToString, - hostToSockAddr, msgType, - nodeNetwork, sockToHostAddress) + Pong (..), Version (..), + hostToSockAddr, nodeNetwork, + sockToHostAddress) import Network.Haskoin.Node.Common (HostPort, Manager, ManagerConfig (..), ManagerMessage (..), @@ -111,22 +109,17 @@ where mgr = inboxToMailbox inbox go = do - $(logDebugS) "Manager" "Initializing" putBestBlock <=< receiveMatch inbox $ \case ManagerBestBlock b -> Just b _ -> Nothing - $(logDebugS) "Manager" "Initialization complete" withConnectLoop mgr $ forever $ do - $(logDebugS) "Manager" "Awaiting message" m <- receive inbox managerMessage m f (a, mex) = ManagerPeerDied a mex `sendSTM` mgr putBestBlock :: MonadManager m => BlockHeight -> m () -putBestBlock bb = do - $(logDebugS) "Manager" $ "Best block at height " <> cs (show bb) - asks myBestBlock >>= \b -> atomically $ writeTVar b bb +putBestBlock bb = asks myBestBlock >>= \b -> atomically $ writeTVar b bb getBestBlock :: MonadManager m => m BlockHeight getBestBlock = asks myBestBlock >>= readTVarIO @@ -141,22 +134,16 @@ loadStaticPeers :: (MonadUnliftIO m, MonadManager m) => m () loadStaticPeers = do - $(logDebugS) "Manager" "Loading static peers" xs <- asks (mgrConfPeers . myConfig) mapM_ newPeer =<< concat <$> mapM toSockAddr xs loadNetSeeds :: (MonadUnliftIO m, MonadManager m) => m () loadNetSeeds = asks (mgrConfDiscover . myConfig) >>= \discover -> - if discover - then do - net <- getNetwork - $(logDebugS) "Manager" "Loading network seeds" - ss <- concat <$> mapM toSockAddr (networkSeeds net) - $(logDebugS) "Manager" $ - "Adding " <> cs (show (length ss)) <> " seed peers" - mapM_ newPeer ss - else $(logDebugS) "Manager" "Peer discovery disabled" + when discover $ do + net <- getNetwork + ss <- concat <$> mapM toSockAddr (networkSeeds net) + mapM_ newPeer ss logConnectedPeers :: MonadManager m => m () logConnectedPeers = do @@ -183,14 +170,10 @@ s <- atomically $ peerString b p e <- runExceptT $ do - let ua = getVarString $ userAgent v - $(logDebugS) "Manager" $ - "Got version from peer " <> s <> ": " <> cs ua o <- ExceptT . atomically $ setPeerVersion b p v when (onlinePeerConnected o) $ announcePeer p case e of Right () -> do - $(logDebugS) "Manager" $ "Version accepted for peer " <> s MVerAck `sendMessage` p Left x -> do $(logErrorS) "Manager" $ @@ -201,89 +184,50 @@ b <- asks onlinePeers s <- atomically $ peerString b p atomically (setPeerVerAck b p) >>= \case - Just o -> do - $(logDebugS) "Manager" $ "Received verack from peer: " <> s - when (onlinePeerConnected o) $ announcePeer p + Just o -> when (onlinePeerConnected o) $ announcePeer p Nothing -> do $(logErrorS) "Manager" $ "Received verack from unknown peer: " <> s killPeer UnknownPeer p -managerMessage (ManagerPeerMessage p (MAddr (Addr nas))) = do - b <- asks onlinePeers - s <- atomically $ peerString b p - let n = length nas - $(logDebugS) "Manager" $ - "Received " <> cs (show n) <> " addresses from peer " <> s +managerMessage (ManagerPeerMessage _ (MAddr (Addr nas))) = asks (mgrConfDiscover . myConfig) >>= \discover -> - if discover - then do - let sas = map (hostToSockAddr . naAddress . snd) nas - forM_ sas newPeer - else $(logDebugS) - "Manager" - "Ignoring new peers since peer discovery disabled" + when discover $ do + let sas = map (hostToSockAddr . naAddress . snd) nas + $(logInfoS) "Manager" $ + "Adding " <> cs (show (length sas)) <> " new peers" + forM_ sas newPeer managerMessage (ManagerPeerMessage p m@(MPong (Pong n))) = do now <- liftIO getCurrentTime b <- asks onlinePeers - s <- atomically $ peerString b p atomically (gotPong b n now p) >>= \case - Nothing -> do - $(logDebugS) "Manager" $ - "Forwarding pong " <> cs (show n) <> " from " <> s - forwardMessage p m - Just d -> do - let ms = fromRational . toRational $ d * 1000 :: Double - $(logDebugS) "Manager" $ - "Ping roundtrip to " <> s <> ": " <> cs (show ms) <> " ms" + Nothing -> forwardMessage p m + Just _ -> return () -managerMessage (ManagerPeerMessage p (MPing (Ping n))) = do - b <- asks onlinePeers - s <- atomically $ peerString b p - $(logDebugS) "Manager" $ - "Responding to ping " <> cs (show n) <> " from " <> s +managerMessage (ManagerPeerMessage p (MPing (Ping n))) = MPong (Pong n) `sendMessage` p -managerMessage (ManagerPeerMessage p m) = do - b <- asks onlinePeers - s <- atomically $ peerString b p - let cmd = commandToString $ msgType m - $(logDebugS) "Manager" $ - "Forwarding message " <> cs cmd <> " from peer " <> s - forwardMessage p m +managerMessage (ManagerPeerMessage p m) = forwardMessage p m -managerMessage (ManagerBestBlock h) = do - $(logDebugS) "Manager" $ "Setting best block at height " <> cs (show h) - putBestBlock h +managerMessage (ManagerBestBlock h) = putBestBlock h managerMessage ManagerConnect = do l <- length <$> getConnectedPeers x <- asks (mgrConfMaxPeers . myConfig) - if l < x - then getNewPeer >>= \case - Nothing -> - $(logDebugS) "Manager" "No other peers available to connect" - Just sa -> connectPeer sa - else $(logDebugS) "Manager" "Enough peers connected" + when (l < x) $ + getNewPeer >>= \case + Nothing -> return () + Just sa -> connectPeer sa managerMessage (ManagerPeerDied a e) = processPeerOffline a e managerMessage (ManagerGetPeers reply) = do - $(logDebugS) "Manager" "Responding to request for connected peers" ps <- getConnectedPeers - $(logDebugS) "Manager" $ - "There are " <> cs (show (length ps)) <> " connected peers" atomically $ reply ps managerMessage (ManagerGetOnlinePeer p reply) = do - $(logDebugS) "Manager" "Responding to request for particular peer" b <- asks onlinePeers - m <- atomically $ findPeer b p >>= \o -> reply o >> return o - case m of - Nothing -> $(logDebugS) "Manager" "Requested peer not found" - Just o -> - $(logDebugS) "Manager" $ - "Peer found at address: " <> cs (show (onlinePeerAddress o)) + atomically $ findPeer b p >>= reply managerMessage (ManagerCheckPeer p) = checkPeer p @@ -292,7 +236,6 @@ ManagerConfig {mgrConfTimeout = to} <- asks myConfig b <- asks onlinePeers s <- atomically $ peerString b p - $(logDebugS) "Manager" $ "Checking on peer " <> s atomically (findPeer b p) >>= \case Nothing -> return () Just o -> do @@ -302,12 +245,10 @@ Nothing -> pingPeer p Just t -> do now <- liftIO getCurrentTime - if diffUTCTime now t > fromIntegral to - then do - $(logErrorS) "Manager" $ - "Peer " <> s <> " did not respond ping on time" - killPeer PeerTimeout p - else $(logDebugS) "Manager" $ "peer " <> s <> " awaiting pong" + when (diffUTCTime now t > fromIntegral to) $ do + $(logErrorS) "Manager" $ + "Peer " <> s <> " did not respond ping on time" + killPeer PeerTimeout p pingPeer :: MonadManager m => Peer -> m () pingPeer p = do @@ -320,12 +261,8 @@ n <- liftIO randomIO now <- liftIO getCurrentTime atomically (setPeerPing b n now p) - $(logDebugS) "Manager" $ - "Sending ping " <> cs (show n) <> " to peer " <> s MPing (Ping n) `sendMessage` p - | otherwise -> - $(logWarnS) "Manager" $ - "Will not ping peer " <> s <> " until handshake complete" + | otherwise -> return () processPeerOffline :: MonadManager m => Child -> Maybe SomeException -> m () processPeerOffline a e = do @@ -368,9 +305,7 @@ managerEvent $ PeerConnected p a logConnectedPeers managerCheck p mgr - Just OnlinePeer {onlinePeerConnected = False} -> - $(logErrorS) "Manager" $ - "Not announcing because not handshaken: " <> s + Just OnlinePeer {onlinePeerConnected = False} -> return () Nothing -> $(logErrorS) "Manager" "Will not announce unknown peer" getNewPeer :: (MonadUnliftIO m, MonadManager m) => m (Maybe SockAddr) @@ -439,14 +374,12 @@ -> Manager -> (Async a -> m a) -> m a -withPeerLoop sa p mgr = withAsync go +withPeerLoop _ p mgr = withAsync go where go = forever $ do threadDelay =<< liftIO (randomRIO (30 * 1000 * 1000, 90 * 1000 * 1000)) - $(logDebugS) "Manager" $ - "Ping manager for peer housekeeping: " <> cs (show sa) ManagerCheckPeer p `send` mgr withConnectLoop :: (MonadLogger m, MonadUnliftIO m) => Manager -> m a -> m a @@ -456,7 +389,6 @@ forever $ do threadDelay =<< liftIO (randomRIO (2 * 1000 * 1000, 10 * 1000 * 1000)) - $(logDebugS) "Manager" "Ping manager for general housekeeping" ManagerConnect `send` mgr -- | Add a peer. diff --git a/src/Network/Haskoin/Node/Peer.hs b/src/Network/Haskoin/Node/Peer.hs --- a/src/Network/Haskoin/Node/Peer.hs +++ b/src/Network/Haskoin/Node/Peer.hs @@ -23,8 +23,7 @@ mapM_C, runConduit, takeCE, yield, (.|)) import Control.Monad (forever, when) -import Control.Monad.Logger (MonadLoggerIO, logDebugS, - logErrorS) +import Control.Monad.Logger (MonadLoggerIO, logErrorS) import Control.Monad.Reader (runReaderT) import Data.ByteString (ByteString) import qualified Data.ByteString as B @@ -34,8 +33,7 @@ import Data.Text (Text) import Network.Haskoin.Constants (Network) import Network.Haskoin.Network (Message, MessageHeader (..), - commandToString, getMessage, - msgType, putMessage) + getMessage, putMessage) import Network.Haskoin.Node.Common (PeerConfig (..), PeerException (..), PeerMessage (..), withConnection) @@ -55,10 +53,8 @@ where a = peerConfAddress pc go = forever $ do - $(logDebugS) s "Awaiting message" receive inbox >>= dispatchMessage pc net = peerConfNetwork pc - s = peerString (peerConfAddress pc) peer_session ad = let ins = appSource ad ons = appSink ad @@ -72,20 +68,10 @@ -- | Internal function to dispatch peer messages. dispatchMessage :: MonadLoggerIO m => PeerConfig -> PeerMessage -> ConduitT i Message m () -dispatchMessage cfg (SendMessage msg) = do - $(logDebugS) (peerString (peerConfAddress cfg)) $ - "Outgoing: " <> cs (commandToString (msgType msg)) - yield msg -dispatchMessage cfg (GetPublisher reply) = do - $(logDebugS) - (peerString (peerConfAddress cfg)) - "Replying to publisher request" - atomically $ reply (peerConfListen cfg) -dispatchMessage cfg (KillPeer e) = do - $(logErrorS) s $ "Killing peer via mailbox request: " <> cs (show e) - throwIO e - where - s = peerString (peerConfAddress cfg) +dispatchMessage _ (SendMessage msg) = yield msg +dispatchMessage cfg (GetPublisher reply) = + atomically (reply (peerConfListen cfg)) +dispatchMessage _ (KillPeer e) = throwIO e -- | Internal conduit to parse messages coming from peer. inPeerConduit :: @@ -111,10 +97,7 @@ $(logErrorS) (peerString a) $ "Cannot decode payload: " <> cs (show e) throwIO CannotDecodePayload - Right msg -> do - $(logDebugS) (peerString a) $ - "Incoming: " <> cs (commandToString (msgType msg)) - yield msg + Right msg -> yield msg -- | Outgoing peer conduit to serialize and send messages. outPeerConduit :: Monad m => Network -> ConduitT Message ByteString m ()