txgen-mvar: resolve hostname in error handler

This does a reverse DNS lookup in handleTxSubmissionClientError in
order to report symbolic host names in error messages.

bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx.hs

@@ -1,7 +1,10 @@
+{-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE ViewPatterns #-}
 
 {-# OPTIONS_GHC -Wno-all-missed-specialisations #-}
 {-# OPTIONS_GHC -Wno-missed-specialisations #-}
@@ -16,21 +19,6 @@ module Cardano.Benchmarking.GeneratorTx
   , waitBenchmark
   ) where
 
-import           Cardano.Prelude
-import           Prelude (String)
-
-import qualified Control.Concurrent.STM as STM
-import qualified Data.Time.Clock as Clock
-
-import qualified Data.List.NonEmpty as NE
-import           Data.Text (pack)
-import           Network.Socket (AddrInfo (..), AddrInfoFlag (..), Family (..), SocketType (Stream),
-                   addrFamily, addrFlags, addrSocketType, defaultHints, getAddrInfo)
-
-import           Cardano.Logging
-
-import           Cardano.Node.Configuration.NodeAddress
-
 import           Cardano.Api hiding (txFee)
 
 import           Cardano.Benchmarking.GeneratorTx.NodeToNode
@@ -40,8 +28,30 @@ import           Cardano.Benchmarking.LogTypes
 import           Cardano.Benchmarking.TpsThrottle
 import           Cardano.Benchmarking.Types
 import           Cardano.Benchmarking.Wallet (TxStream)
+import           Cardano.Logging
+import           Cardano.Node.Configuration.NodeAddress
+import           Cardano.Prelude
 import           Cardano.TxGenerator.Types (NumberOfTxs, TPSRate, TxGenError (..))
 
+import           Prelude (String)
+
+import           Control.Arrow ((+++))
+import qualified Control.Concurrent.STM as STM
+import           Control.Exception (throw)
+import qualified Data.ByteString.Char8 as BS
+import           Data.Functor.Adjunction (uncozipL)
+import qualified Data.List as List (intercalate, unlines)
+import qualified Data.List.NonEmpty as NE
+import           Data.Text (pack)
+import qualified Data.Time.Clock as Clock
+import           GHC.IO.Exception (IOErrorType (..), IOException (..))
+import           Network.DNS (DNSError (DecodeError), Domain, defaultResolvConf, lookupRDNS,
+                   makeResolvSeed, withResolver)
+import           Network.Socket (AddrInfo (..), AddrInfoFlag (..), Family (..), SockAddr (..),
+                   SocketType (Stream), addrFamily, addrFlags, addrSocketType, defaultHints,
+                   getAddrInfo, hostAddress6ToTuple, hostAddressToTuple)
+import           Numeric (showHex)
+
 
 type AsyncBenchmarkControl = (Async (), [Async ()], IO SubmissionSummary, IO ())
 
@@ -66,6 +76,23 @@ lookupNodeAddress node = do
     , addrCanonName  = Nothing
     }
 
+addrInfoToName :: AddrInfo -> Either FilePath Domain
+addrInfoToName AddrInfo {..} =
+  case addrAddress of
+    SockAddrInet  _port (hostAddressToTuple -> _addr@(b1,b2,b3,b4)) ->
+      Right $ mkIPname "." show [b1,b2,b3,b4]
+    SockAddrInet6 _port _flowInfo addr6 _scopeID ->
+      let (b1,b2,b3,b4,b5,b6,b7,b8) = hostAddress6ToTuple addr6
+       in Right $ mkIPname ":" showHex' [b1,b2,b3,b4,b5,b6,b7,b8]
+    SockAddrUnix path -> Left path
+  where
+    mkIPname :: ByteString -> (t -> String) -> [t] -> ByteString
+    mkIPname separator render =
+      BS.intercalate separator . map (BS.pack . render)
+    showHex' :: (Integral t, Show t) => t -> String
+    showHex' 0 = ""
+    showHex' n = showHex n ""
+
 handleTxSubmissionClientError ::
      Trace IO (TraceBenchTxSubmit TxId)
   -> Network.Socket.AddrInfo
@@ -79,16 +106,47 @@ handleTxSubmissionClientError
   reportRef
   errorPolicy
   (SomeException err) = do
-    submitThreadReport reportRef (Left errDesc)
-    case errorPolicy of
-      FailOnError -> throwIO err
-      LogErrors   -> traceWith traceSubmit $
-        TraceBenchTxSubError (pack errDesc)
+    resolveSeed <- makeResolvSeed defaultResolvConf
+    errorOrName <- withResolver resolveSeed \resolver ->
+                      liftM join . uncozipL .
+                          (pure . mkUnixError +++ lookupRDNS resolver) $
+                                  addrInfoToName remoteAddr
+    case errorOrName of
+      Left  dnsErr     -> throw =<< mkDNSErr dnsErr
+      Right maybeNames -> do
+        let errDesc = mconcat
+              [ "Exception while talking to peer "
+              , case maybeNames of
+                  []         -> "<<< IP unresolved >>>"
+                  name@(_:_) -> List.intercalate ", " $ map BS.unpack name
+              , " (", show $ addrAddress remoteAddr, "): "
+              , show err]
+        submitThreadReport reportRef (Left errDesc)
+        case errorPolicy of
+          FailOnError -> throwIO err
+          LogErrors   -> traceWith traceSubmit $
+            TraceBenchTxSubError (pack errDesc)
    where
-    errDesc = mconcat
-      [ "Exception while talking to peer "
-      , " (", show (addrAddress remoteAddr), "): "
-      , show err]
+    mkUnixError :: String -> DNSError
+    mkUnixError path =
+      DecodeError $ "Unix domain socket passed to reverse DNS: " ++ path
+    mkDNSErr :: DNSError -> IO IOException
+    mkDNSErr dnsError = do
+         let ioe_description = List.unlines $
+               [ List.intercalate " " $
+                   [ "Encountered Unix domain socket attempting to resolve"
+                   , "remote address"
+                   , show remoteAddr
+                   , "to hostname via reverse DNS:"
+                   , show dnsError ]
+               , "in an attempt to handle the following exception: "
+               , displayException err ]
+         throw IOError { ioe_handle   = Nothing
+                       , ioe_type     = InvalidArgument
+                       , ioe_errno    = Nothing
+                       , ioe_filename = Just "GeneratorTx.hs"
+                       , ioe_location = "handleTxSubmissionClientError"
+                       , .. }
 
 walletBenchmark :: forall era. IsShelleyBasedEra era
   => Trace IO (TraceBenchTxSubmit TxId)

bench/tx-generator/tx-generator.cabal

@@ -93,6 +93,7 @@ library
   autogen-modules:      Paths_tx_generator
 
   build-depends:        base >=4.12 && <5
+                      , adjunctions
                       , aeson
                       , aeson-pretty
                       , async
@@ -118,6 +119,7 @@ library
                       , containers
                       , constraints-extras
                       , dlist
+                      , dns
                       , extra
                       , formatting
                       , generic-monoid
@@ -144,6 +146,7 @@ library
                       , prettyprinter
                       , scientific
                       , stm
+                      , template-haskell
                       , text
                       , time
                       , trace-dispatcher