smp-server: log resolver errors

src/Simplex/Messaging/Server/Names.hs

@@ -16,11 +16,13 @@ module Simplex.Messaging.Server.Names
 where
 
 import qualified Control.Exception as E
-import Control.Logger.Simple (logError)
-import Data.Bifunctor (first)
+import Control.Logger.Simple (logError, logWarn)
 import Data.Maybe (fromMaybe)
+import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Text.Encoding (decodeLatin1)
+import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime)
+import Network.HTTP.Client (HttpException (..))
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Protocol (NameErrorType (..), NameQuery, NameResponse)
 import Simplex.Messaging.Server.Names.HttpResolver
@@ -32,6 +34,7 @@ import Simplex.Messaging.Server.Names.HttpResolver
     newResolverEnv,
     resolveHttp,
   )
+import Simplex.Messaging.Util (diffToMilliseconds, tshow)
 import System.Timeout (timeout)
 
 data NamesConfig = NamesConfig
@@ -61,18 +64,32 @@ pingEndpoint NamesEnv {resolverEnv, config} =
 
 resolveName :: NamesEnv -> NameQuery -> IO (Either NameErrorType NameResponse)
 resolveName env q = do
+  start <- getCurrentTime
   r <- E.try (timeout (resolverTimeoutMs (config env) * 1000) (fetch env q))
   case r of
-    Right result -> pure (fromMaybe (Left (RESOLVER "timeout")) result)
+    Right (Just (Right res)) -> pure (Right res)
+    Right (Just (Left e)) -> failed start (resolverErrorText e) (mapResolverError e)
+    Right Nothing -> failed start "timeout" (RESOLVER "timeout")
     Left e
       | Just (_ :: E.SomeAsyncException) <- E.fromException e -> E.throwIO e
       | otherwise -> do
           logError $ "[NAMES] resolver fetch raised " <> T.pack (E.displayException e)
           pure (Left (RESOLVER "resolver error"))
+  where
+    failed :: UTCTime -> Text -> NameErrorType -> IO (Either NameErrorType NameResponse)
+    failed start reason err = do
+      ms <- diffToMilliseconds . (`diffUTCTime` start) <$> getCurrentTime
+      logWarn $ "[NAMES] resolver failed after " <> tshow ms <> "ms: " <> reason
+      pure (Left err)
 
-fetch :: NamesEnv -> NameQuery -> IO (Either NameErrorType NameResponse)
-fetch NamesEnv {resolverEnv} q =
-  first mapResolverError <$> resolveHttp resolverEnv (decodeLatin1 $ smpEncode q)
+fetch :: NamesEnv -> NameQuery -> IO (Either ResolverError NameResponse)
+fetch NamesEnv {resolverEnv} q = resolveHttp resolverEnv (decodeLatin1 $ smpEncode q)
+
+-- The shown request would put the queried name in the log, so only the content is shown.
+resolverErrorText :: ResolverError -> Text
+resolverErrorText = \case
+  HttpFailure (HttpExceptionRequest _ content) -> tshow content
+  e -> tshow e
 
 mapResolverError :: ResolverError -> NameErrorType
 mapResolverError = \case