log: Clean up P2P logs

Change-Id: I4db5f0feb0e72619bdc2476fc70184a6f166edda

changes/2024-05-30T163404-0400.txt

@@ -0,0 +1 @@
+Shorter and improved P2P log messages

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

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"

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

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