log server errors as critical log messages when an exception is raise…

…d by

  It took us long enough to get to identify the source of the failure because the wallet is silently raising an exception and terminating nodes of the cluster, but there are some ghost threads which remain hanging and prevent other bracket functions to fully move forward and stop.
  At least now, an error message is printed to help debugging the root cause of the issue.

lib/shelley/test/integration/Main.hs

@@ -74,7 +74,7 @@ import Control.Concurrent.Async
 import Control.Concurrent.MVar
     ( newEmptyMVar, putMVar, takeMVar )
 import Control.Exception
-    ( throwIO )
+    ( SomeException, handle, throwIO )
 import Control.Monad.IO.Class
     ( liftIO )
 import Control.Tracer
@@ -275,12 +275,12 @@ specWithServer (tr, tracers) = aroundAll withContext
                 concatMap genRewardAccounts mirMnemonics
         moveInstantaneousRewardsTo tr' dir rewards
 
-    onClusterStart
-        action dir dbDecorator (RunningNode socketPath block0 (gp, vData)) = do
+    onClusterStart action dir dbDecorator node = do
         -- NOTE: We may want to keep a wallet running across the fork, but
         -- having three callbacks like this might not work well for that.
         withTempDir tr' dir "wallets" $ \db -> do
-            serveWallet @(IO ShelleyEra)
+            handle (\e -> traceWith tr (MsgServerError e) >> throwIO e)
+            $ serveWallet @(IO ShelleyEra)
                 (SomeNetworkDiscriminant $ Proxy @'Mainnet)
                 tracers
                 (SyncTolerance 10)
@@ -294,6 +294,8 @@ specWithServer (tr, tracers) = aroundAll withContext
                 block0
                 (gp, vData)
                 (action gp)
+      where
+        RunningNode socketPath block0 (gp, vData) = node
 
 {-------------------------------------------------------------------------------
                                     Logging
@@ -305,6 +307,7 @@ data TestsLog
     | MsgSettingUpFaucet
     | MsgCluster ClusterLog
     | MsgPoolGarbageCollectionEvent PoolGarbageCollectionEvent
+    | MsgServerError SomeException
     deriving (Show)
 
 instance ToText TestsLog where
@@ -324,6 +327,7 @@ instance ToText TestsLog where
                     , T.unwords (T.pack . show <$> ps)
                     ]
             ]
+        MsgServerError e -> T.pack (show e)
 
 instance HasPrivacyAnnotation TestsLog
 instance HasSeverityAnnotation TestsLog where
@@ -333,6 +337,7 @@ instance HasSeverityAnnotation TestsLog where
         MsgBaseUrl _ -> Notice
         MsgCluster msg -> getSeverityAnnotation msg
         MsgPoolGarbageCollectionEvent _ -> Info
+        MsgServerError{} -> Critical
 
 withTracers
     :: ((Tracer IO TestsLog, Tracers IO) -> IO a)