From 29a30bb19db68e46f6a72a0ff40155a928b460e1 Mon Sep 17 00:00:00 2001 From: Edmund Noble Date: Sat, 25 May 2024 12:11:06 -0400 Subject: [PATCH] log: Clean up P2P logs Change-Id: I4db5f0feb0e72619bdc2476fc70184a6f166edda --- changes/2024-05-30T163404-0400.txt | 1 + src/Chainweb/Chainweb/PeerResources.hs | 2 +- src/Chainweb/NodeVersion.hs | 4 +- src/Chainweb/Utils.hs | 51 +++++++++++++++++++++++-- src/P2P/Node.hs | 52 +++++++++++++++----------- 5 files changed, 83 insertions(+), 27 deletions(-) create mode 100644 changes/2024-05-30T163404-0400.txt diff --git a/changes/2024-05-30T163404-0400.txt b/changes/2024-05-30T163404-0400.txt new file mode 100644 index 0000000000..922ce32e16 --- /dev/null +++ b/changes/2024-05-30T163404-0400.txt @@ -0,0 +1 @@ +Shorter and improved P2P log messages diff --git a/src/Chainweb/Chainweb/PeerResources.hs b/src/Chainweb/Chainweb/PeerResources.hs index 536a256595..e823821fc4 100644 --- a/src/Chainweb/Chainweb/PeerResources.hs +++ b/src/Chainweb/Chainweb/PeerResources.hs @@ -175,7 +175,7 @@ withHost withHost mgr v conf logger f | null peers = do logFunctionText logger Warn - $ "Unable verify configured host " <> toText confHost <> ": No peers are available." + $ "Unable to verify configured host " <> toText confHost <> ": No peers are available." f (set (p2pConfigPeer . peerConfigHost) confHost conf) | anyIpv4 == confHost = do h <- getHost mgr v logger peers >>= \case diff --git a/src/Chainweb/NodeVersion.hs b/src/Chainweb/NodeVersion.hs index 510f6c6d85..7e217c9fa3 100644 --- a/src/Chainweb/NodeVersion.hs +++ b/src/Chainweb/NodeVersion.hs @@ -110,7 +110,9 @@ getNodeVersion mgr ver addr maybeReq = do -- $ recoverAll policy $ const $ HTTP.responseHeaders <$> HTTP.httpNoBody url mgr return $ do - r <- first sshow hdrs + r <- first + (matchOrDisplayException @HTTP.HttpException showHTTPRequestException) + hdrs h <- case lookup chainwebNodeVersionHeaderName r of Nothing -> Left $ "missing " <> CI.original chainwebNodeVersionHeaderName <> " header" diff --git a/src/Chainweb/Utils.hs b/src/Chainweb/Utils.hs index ab5effa190..1f58ea1e85 100644 --- a/src/Chainweb/Utils.hs +++ b/src/Chainweb/Utils.hs @@ -80,6 +80,9 @@ module Chainweb.Utils , interleaveIO , mutableVectorFromList , timeoutYield +, showClientError +, showHTTPRequestException +, matchOrDisplayException -- * Encoding and Serialization , EncodingException(..) @@ -154,6 +157,7 @@ module Chainweb.Utils , enableConfigConfig , enableConfigEnabled , defaultEnableConfig +, defaultDisableConfig , pEnableConfig , enabledConfig , validateEnableConfig @@ -267,7 +271,7 @@ import GHC.TypeLits (KnownSymbol, symbolVal) import qualified Network.Connection as HTTP import qualified Network.HTTP.Client as HTTP import qualified Network.HTTP.Client.TLS as HTTP -import Network.Socket +import Network.Socket hiding (Debug) import Numeric.Natural @@ -284,6 +288,8 @@ import qualified System.Timeout as Timeout import Text.Printf (printf) import Text.Read (readEither) +import qualified Servant.Client +import qualified Network.HTTP.Types as HTTP -- -------------------------------------------------------------------------- -- -- SI unit prefixes @@ -928,7 +934,7 @@ tryAllSynchronous = trySynchronous -- runForever :: (LogLevel -> T.Text -> IO ()) -> T.Text -> IO () -> IO () runForever logfun name a = mask $ \umask -> do - logfun Info $ "start " <> name + logfun Debug $ "start " <> name let go = do forever (umask a) `catchAllSynchronous` \e -> logfun Error $ name <> " failed: " <> sshow e <> ". Restarting ..." @@ -955,7 +961,7 @@ runForeverThrottled -> IO () runForeverThrottled logfun name burst rate a = mask $ \umask -> do tokenBucket <- newTokenBucket - logfun Info $ "start " <> name + logfun Debug $ "start " <> name let runThrottled = tokenBucketWait tokenBucket burst rate >> a go = do forever (umask runThrottled) `catchAllSynchronous` \e -> @@ -986,6 +992,14 @@ defaultEnableConfig a = EnableConfig , _enableConfigConfig = a } +-- | The default is that the configured component is disabled. +-- +defaultDisableConfig :: a -> EnableConfig a +defaultDisableConfig a = EnableConfig + { _enableConfigEnabled = False + , _enableConfigConfig = a + } + enableConfigProperties :: ToJSON a => KeyValue e kv => EnableConfig a -> [kv] enableConfigProperties o = [ "enabled" .= _enableConfigEnabled o @@ -1408,3 +1422,34 @@ parseUtcTime d = case parseTimeM False defaultTimeLocale fmt d of timeoutYield :: Int -> IO a -> IO (Maybe a) timeoutYield time act = Timeout.timeout time (act <* threadDelay 1) + +showClientError :: Servant.Client.ClientError -> T.Text +showClientError (Servant.Client.FailureResponse _ resp) = + "Error code " <> sshow (HTTP.statusCode $ Servant.Client.responseStatusCode resp) +showClientError (Servant.Client.ConnectionError anyException) = + matchOrDisplayException @HTTP.HttpException showHTTPRequestException anyException +showClientError e = + T.pack $ displayException e + +showHTTPRequestException :: HTTP.HttpException -> T.Text +showHTTPRequestException (HTTP.HttpExceptionRequest _request content) + = case content of + HTTP.StatusCodeException resp _ -> + "Error status code: " <> + sshow (HTTP.statusCode $ HTTP.responseStatus resp) + HTTP.TooManyRedirects _ -> "Too many redirects" + HTTP.InternalException e + | Just (HTTP.HostCannotConnect _ es) <- fromException e + -> "Host cannot connect: " <> sshow es + | otherwise + -> sshow e + _ -> sshow content +showHTTPRequestException ex + = T.pack $ displayException ex + +matchOrDisplayException :: Exception e => (e -> T.Text) -> SomeException -> T.Text +matchOrDisplayException display anyException + | Just specificException <- fromException anyException + = display specificException + | otherwise + = T.pack $ displayException anyException diff --git a/src/P2P/Node.hs b/src/P2P/Node.hs index 86f520feca..8705b6c654 100644 --- a/src/P2P/Node.hs +++ b/src/P2P/Node.hs @@ -10,6 +10,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} -- | -- Module: P2P.Node @@ -337,21 +338,21 @@ getNewPeerManager = readIORef newPeerManager -- Guard PeerDB data PeerValidationFailure - = IsReservedHostAddress !PeerInfo - | IsNotReachable !PeerInfo !T.Text - | NodeVersionNotAccepted !PeerInfo !NodeVersion - | IsLocalPeerAddress !PeerInfo + = IsReservedHostAddress + | IsNotReachable !T.Text + | NodeVersionNotAccepted !NodeVersion + | IsLocalPeerAddress deriving (Show, Eq, Ord, Generic, NFData, ToJSON) -instance Exception PeerValidationFailure where - displayException (IsReservedHostAddress p) - = "The peer info " <> T.unpack (showInfo p) <> " is form a reserved IP address range" - displayException (IsNotReachable p t) - = "The peer info " <> T.unpack (showInfo p) <> " can't be reached: " <> T.unpack t - displayException (NodeVersionNotAccepted p v) - = "The peer info " <> T.unpack (showInfo p) <> " has a chainweb node version that is not acceptable: " <> T.unpack (toText v) - displayException (IsLocalPeerAddress p) - = "The peer info " <> T.unpack (showInfo p) <> " is the address of the local peer" +displayPeerValidationFailure :: PeerValidationFailure -> T.Text +displayPeerValidationFailure IsReservedHostAddress + = "is from a reserved IP address range" +displayPeerValidationFailure (IsNotReachable t) + = "can't be reached: " <> t +displayPeerValidationFailure (NodeVersionNotAccepted v) + = "has a chainweb node version that is not acceptable: " <> toText v +displayPeerValidationFailure IsLocalPeerAddress + = "is the address of the local peer" -- | Removes candidate `PeerInfo` that are: -- @@ -374,14 +375,14 @@ guardPeerDb guardPeerDb v nid peerDb pinf = do peers <- peerDbSnapshot peerDb if - | isMe -> return $ Left $ IsLocalPeerAddress pinf + | isMe -> return $ Left $ IsLocalPeerAddress | isKnown peers pinf -> return $ Right pinf - | isReserved -> return $ Left $ IsReservedHostAddress pinf + | isReserved -> return $ Left $ IsReservedHostAddress | otherwise -> canConnect >>= \case - Left e -> return $ Left $ IsNotReachable pinf (sshow e) + Left e -> return $ Left $ IsNotReachable e Right nodeVersion -> if isAcceptedVersion nodeVersion then return $ Right pinf - else return $ Left $ NodeVersionNotAccepted pinf nodeVersion + else return $ Left $ NodeVersionNotAccepted nodeVersion where isReserved :: Bool isReserved = not (v ^. versionDefaults . disablePeerValidation) && isReservedHostAddress (_peerAddr pinf) @@ -407,10 +408,13 @@ guardPeerDbOfNode -> PeerInfo -> IO (Maybe PeerInfo) guardPeerDbOfNode node pinf = go >>= \case - Left (IsLocalPeerAddress _) -> + Left IsLocalPeerAddress -> return Nothing Left e -> do - logg node Info $ "failed to validate peer " <> showInfo pinf <> ": " <> T.pack (displayException e) + logg node Info + $ "failed to validate peer " + <> showInfo pinf <> ": " + <> displayPeerValidationFailure e return Nothing Right x -> return (Just x) where @@ -440,7 +444,7 @@ syncFromPeer node info = do peerDbDelete (_p2pNodePeerDb node) info return False | otherwise -> do - logg node Warn $ "failed to sync peers from " <> showInfo info <> ": " <> sshow e + logg node Warn $ "failed to sync peers from " <> showInfo info <> ": " <> showClientError e return False Right p -> do peers <- peerDbSnapshot peerDb @@ -649,7 +653,11 @@ awaitSessions node = do Right Nothing -> P2pSessionTimeout <$ countTimeout node Right (Just True) -> P2pSessionResultSuccess <$ countSuccess node Right (Just False) -> P2pSessionResultFailure <$ countFailure node - Left e -> P2pSessionException (sshow e) <$ countException node + Left e -> + let errDescription + | Just clientError <- fromException e = showClientError clientError + | otherwise = T.pack $ displayException e + in P2pSessionException errDescription <$ countException node return (p, i, a, result) -- update peer db entry @@ -778,7 +786,7 @@ p2pCreateNode cv nid peer logfun db mgr doPeerSync session = do , _p2pNodeDoPeerSync = doPeerSync } - logfun @T.Text Info "created node" + logfun @T.Text Debug "created node" return s where myInfo = _peerInfo peer