diff --git a/libs/bilge/bilge.cabal b/libs/bilge/bilge.cabal index 8e64bbe92e..9aefddd77d 100644 --- a/libs/bilge/bilge.cabal +++ b/libs/bilge/bilge.cabal @@ -98,6 +98,7 @@ library , uri-bytestring , wai , wai-extra + , wai-utilities , wire-otel default-language: GHC2021 diff --git a/libs/bilge/default.nix b/libs/bilge/default.nix index 1844d50b1d..0f90d357e6 100644 --- a/libs/bilge/default.nix +++ b/libs/bilge/default.nix @@ -26,6 +26,7 @@ , uri-bytestring , wai , wai-extra +, wai-utilities , wire-otel }: mkDerivation { @@ -54,6 +55,7 @@ mkDerivation { uri-bytestring wai wai-extra + wai-utilities wire-otel ]; description = "Library for composing HTTP requests"; diff --git a/libs/bilge/src/Bilge/Assert.hs b/libs/bilge/src/Bilge/Assert.hs index a13e624aa5..5c66904022 100644 --- a/libs/bilge/src/Bilge/Assert.hs +++ b/libs/bilge/src/Bilge/Assert.hs @@ -43,6 +43,7 @@ import Data.ByteString qualified as S import Data.ByteString.Lazy qualified as Lazy import Imports import Network.HTTP.Client +import Network.Wai.Utilities.Exception (displayExceptionNoBacktrace) import System.Console.ANSI import Text.Printf @@ -98,7 +99,7 @@ io m a - printErr e = error $ title "Error executing request: " ++ err (show e) + printErr e = error $ title "Error executing request: " ++ err (displayExceptionNoBacktrace e) -- | Like ' Msg -> Msg rpcExceptionMsg (RPCException sys req ex) = - "remote" .= sys ~~ "path" .= HTTP.path req ~~ headers ~~ msg (show ex) + "remote" .= sys ~~ "path" .= HTTP.path req ~~ headers ~~ msg (displayExceptionNoBacktrace ex) where headers = foldr hdr id (HTTP.requestHeaders req) hdr (k, v) x = x ~~ original k .= v diff --git a/libs/saml2-web-sso/default.nix b/libs/saml2-web-sso/default.nix index cf699cf073..e4d714b714 100644 --- a/libs/saml2-web-sso/default.nix +++ b/libs/saml2-web-sso/default.nix @@ -72,6 +72,7 @@ , uuid , wai , wai-extra +, wai-utilities , warp , word8 , xml-conduit @@ -150,6 +151,7 @@ mkDerivation { uuid wai wai-extra + wai-utilities warp word8 xml-conduit diff --git a/libs/saml2-web-sso/saml2-web-sso.cabal b/libs/saml2-web-sso/saml2-web-sso.cabal index 4d05fc179b..da09daed9e 100644 --- a/libs/saml2-web-sso/saml2-web-sso.cabal +++ b/libs/saml2-web-sso/saml2-web-sso.cabal @@ -145,6 +145,7 @@ library , uuid >=1.3.13 , wai >=3.2.2.1 , wai-extra >=3.0.28 + , wai-utilities , warp >=3.2.28 , word8 >=0.1.3 , xml-conduit >=1.8.0.1 diff --git a/libs/saml2-web-sso/src/SAML2/WebSSO/XML.hs b/libs/saml2-web-sso/src/SAML2/WebSSO/XML.hs index bfff13e20a..e3b77b281f 100644 --- a/libs/saml2-web-sso/src/SAML2/WebSSO/XML.hs +++ b/libs/saml2-web-sso/src/SAML2/WebSSO/XML.hs @@ -49,6 +49,7 @@ import Data.Typeable (Proxy (Proxy), Typeable) import Data.X509 qualified as X509 import GHC.Stack import Network.URI qualified as URI +import Network.Wai.Utilities.Exception (displayExceptionNoBacktrace) import SAML2.Bindings.Identifiers qualified as HX import SAML2.Core qualified as HX import SAML2.Metadata.Metadata qualified as HX @@ -86,7 +87,7 @@ encode = Text.XML.renderText settings . renderToDocument settings = def {rsNamespaces = nameSpaces (Proxy @a), rsXMLDeclaration = True} decode :: forall m a. (HasXMLRoot a, MonadError String m) => LT -> m a -decode = either (throwError . show @SomeException) parseFromDocument . parseText def +decode = either (throwError . displayExceptionNoBacktrace @SomeException) parseFromDocument . parseText def encodeElem :: forall a. (HasXML a) => a -> LT encodeElem = Text.XML.renderText settings . mkDocument' . render @@ -96,7 +97,7 @@ encodeElem = Text.XML.renderText settings . mkDocument' . render mkDocument' bad = error $ "encodeElem: " <> show bad decodeElem :: forall a m. (HasXML a, MonadError String m) => LT -> m a -decodeElem = either (throwError . show @SomeException) parseFromDocument . parseText def +decodeElem = either (throwError . displayExceptionNoBacktrace @SomeException) parseFromDocument . parseText def renderToDocument :: (HasXMLRoot a) => a -> Document renderToDocument = mkDocument . renderRoot diff --git a/libs/saml2-web-sso/src/Text/XML/DSig.hs b/libs/saml2-web-sso/src/Text/XML/DSig.hs index ecf48ff75a..e5cbd50c17 100644 --- a/libs/saml2-web-sso/src/Text/XML/DSig.hs +++ b/libs/saml2-web-sso/src/Text/XML/DSig.hs @@ -72,6 +72,7 @@ import Data.UUID as UUID import Data.X509 qualified as X509 import GHC.Stack import Network.URI (URI (..), parseRelativeReference) +import Network.Wai.Utilities.Exception import SAML2.XML qualified as HS hiding (Node, URI) import SAML2.XML.Canonical qualified as HS import SAML2.XML.Signature qualified as HS @@ -145,7 +146,7 @@ parseKeyInfo doVerify (cs @LT @LBS -> lbs) = case HS.xmlToSAML @HS.KeyInfo =<< s -- | Call 'stripWhitespaceDoc' on a rendered bytestring. stripWhitespaceLBS :: (m ~ Either String) => LBS -> m LBS -stripWhitespaceLBS lbs = renderLBS def . stripWhitespace <$> fmapL show (parseLBS def lbs) +stripWhitespaceLBS lbs = renderLBS def . stripWhitespace <$> fmapL displayExceptionNoBacktrace (parseLBS def lbs) renderKeyInfo :: (HasCallStack) => X509.SignedCertificate -> LT renderKeyInfo cert = cs . ourSamlToXML . HS.KeyInfo Nothing $ NonEmpty.singleton (HS.X509Data (NonEmpty.singleton (HS.X509Certificate cert))) @@ -224,8 +225,8 @@ mkSignCredsWithCert mValidSince size = do verify :: forall m. (MonadError String m) => NonEmpty SignCreds -> LBS -> String -> m HXTC.XmlTree verify creds el sid = case unsafePerformIO (try @SomeException $ verifyIO creds el sid) of Right (_, Right xml) -> pure xml - Right (_, Left exc) -> throwError $ show exc - Left exc -> throwError $ show exc + Right (_, Left signErr) -> throwError $ show signErr + Left exc -> throwError $ displayExceptionNoBacktrace exc -- | Convenient wrapper that picks the ID of the root element node and passes it to `verify`. verifyRoot :: forall m. (MonadError String m) => NonEmpty SignCreds -> LBS -> m HXTC.XmlTree @@ -233,7 +234,7 @@ verifyRoot creds el = do signedID <- do XML.Document _ (XML.Element _ attrs _) _ <- either - (throwError . ("Could not parse signed document: " <>) . cs . show) + (throwError . ("Could not parse signed document: " <>) . cs . displayExceptionNoBacktrace) pure (XML.parseLBS XML.def el) maybe @@ -272,7 +273,7 @@ verifySignatureUnenvelopedSigs :: HS.PublicKeys -> String -> HXTC.XmlTree -> IO verifySignatureUnenvelopedSigs pks xid doc = catchAll $ warpResult <$> verifySignature pks xid doc where catchAll :: IO (Either HS.SignatureError a) -> IO (Either HS.SignatureError a) - catchAll = handle $ pure . Left . HS.SignatureVerificationLegacyFailure . Left . (show @SomeException) + catchAll = handle $ pure . Left . HS.SignatureVerificationLegacyFailure . Left . (displayExceptionNoBacktrace @SomeException) warpResult :: Maybe HXTC.XmlTree -> Either HS.SignatureError HXTC.XmlTree warpResult (Just xml) = Right xml @@ -413,7 +414,7 @@ signRootAt sigPos (SignPrivCreds hashAlg (SignPrivKeyRSA keypair)) doc = } ] docCanonic :: SBS <- - either (throwError . show) (pure . cs) . unsafePerformIO . try @SomeException $ + either (throwError . displayExceptionNoBacktrace) (pure . cs) . unsafePerformIO . try @SomeException $ HS.applyTransforms transforms (HXT.mkRoot [] [docInHXT]) let digest :: SBS digest = case hashAlg of @@ -437,7 +438,7 @@ signRootAt sigPos (SignPrivCreds hashAlg (SignPrivKeyRSA keypair)) doc = -- (note that there are two rounds of SHA256 application, hence two mentions of the has alg here) signedInfoSBS :: SBS <- - either (throwError . show) (pure . cs) . unsafePerformIO . try @SomeException $ + either (throwError . displayExceptionNoBacktrace) (pure . cs) . unsafePerformIO . try @SomeException $ HS.applyCanonicalization (HS.signedInfoCanonicalizationMethod signedInfo) Nothing $ HS.samlToDoc signedInfo sigval :: SBS <- diff --git a/libs/wire-subsystems/src/Wire/ExternalAccess/External.hs b/libs/wire-subsystems/src/Wire/ExternalAccess/External.hs index cd0e67465f..768f37f141 100644 --- a/libs/wire-subsystems/src/Wire/ExternalAccess/External.hs +++ b/libs/wire-subsystems/src/Wire/ExternalAccess/External.hs @@ -188,7 +188,7 @@ deliver env pp = mapM (Async.async . exec) pp >>= foldM evaluate [] . zip (map f field "provider" (toByteString (s ^. serviceRefProvider)) ~~ field "service" (toByteString (s ^. serviceRefId)) ~~ field "bot" (toByteString (botMemId b)) - ~~ field "error" (show ex) + ~~ field "error" (displayException ex) ~~ msg (val "External delivery failure") pure gone Nothing -> do diff --git a/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs index 58e01782d4..2f6ff57836 100644 --- a/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs @@ -27,6 +27,7 @@ import Data.Set qualified as Set import Data.Text.Ascii qualified as AsciiText import Data.Text.Encoding qualified as Text import Imports +import Network.Wai.Utilities.Exception (displayExceptionNoBacktrace) import Polysemy import Polysemy.Error import Polysemy.Input (Input, input, runInputConst) @@ -265,7 +266,7 @@ logInvitationRequest context action = runError action >>= \case Left e -> do Log.warn $ - msg @String ("Failed to create invitation: " <> show e) + msg @String ("Failed to create invitation: " <> displayExceptionNoBacktrace e) . context throw e Right res@(_, code) -> do diff --git a/services/background-worker/src/Wire/BackgroundWorker/Jobs/Registry.hs b/services/background-worker/src/Wire/BackgroundWorker/Jobs/Registry.hs index e9e6240ada..1c9b3416bd 100644 --- a/services/background-worker/src/Wire/BackgroundWorker/Jobs/Registry.hs +++ b/services/background-worker/src/Wire/BackgroundWorker/Jobs/Registry.hs @@ -78,9 +78,9 @@ dispatchJob job = do . interpretRace . runDelay . runError - . mapError @FederationError (T.pack . show) + . mapError @FederationError (T.pack . displayException) . mapError @UsageError (T.pack . show) - . mapError @ParseException (T.pack . show) + . mapError @ParseException (T.pack . displayException) . mapError @MigrationError (T.pack . show) . interpretTinyLog env job.requestId job.jobId . runInputConst env.hasqlPool diff --git a/services/brig/src/Brig/AWS.hs b/services/brig/src/Brig/AWS.hs index e304440ce2..5bcbf90ecd 100644 --- a/services/brig/src/Brig/AWS.hs +++ b/services/brig/src/Brig/AWS.hs @@ -182,7 +182,7 @@ listen throttleMillis url callback = forever . handleAny unexpectedError $ do liftIO $ callback n for_ (m ^. SQS.message_receiptHandle) (void . send . SQS.newDeleteMessage url) unexpectedError x = do - err $ "error" .= show x ~~ msg (val "Failed to read or process message from SQS") + err $ "error" .= displayException x ~~ msg (val "Failed to read or process message from SQS") threadDelay 3000000 enqueueStandard :: Text -> BL.ByteString -> Amazon SQS.SendMessageResponse diff --git a/services/brig/src/Brig/Queue/Stomp.hs b/services/brig/src/Brig/Queue/Stomp.hs index f92f5be658..8fa9b04336 100644 --- a/services/brig/src/Brig/Queue/Stomp.hs +++ b/services/brig/src/Brig/Queue/Stomp.hs @@ -166,7 +166,7 @@ listen b q callback = Log.err $ msg (val "Exception when listening to a STOMP queue") ~~ field "queue" (show q) - ~~ field "error" (show e) + ~~ field "error" (displayException e) pure True -- Note [exception handling] diff --git a/services/brig/src/Brig/Run.hs b/services/brig/src/Brig/Run.hs index f1a1ea4a92..5b5d0f9681 100644 --- a/services/brig/src/Brig/Run.hs +++ b/services/brig/src/Brig/Run.hs @@ -241,7 +241,7 @@ pendingActivationCleanup = do safeForever funName action = forever $ action `catchAny` \exc -> do - err $ "error" .= show exc ~~ msg (val $ UTF8.fromString funName <> " failed") + err $ "error" .= displayException exc ~~ msg (val $ UTF8.fromString funName <> " failed") -- pause to keep worst-case noise in logs manageable threadDelay 60_000_000 diff --git a/services/cannon/src/Cannon/App.hs b/services/cannon/src/Cannon/App.hs index 2ad956a087..ed7daa0784 100644 --- a/services/cannon/src/Cannon/App.hs +++ b/services/cannon/src/Cannon/App.hs @@ -159,8 +159,8 @@ rejectOnError p x = do ioErrors :: (MonadLogger m) => Key -> [Handler m ()] ioErrors k = let f s = Logger.err $ client (key2bytes k) . msg s - in [ Handler $ \(x :: HandshakeException) -> f (show x), - Handler $ \(x :: IOException) -> f (show x) + in [ Handler $ \(x :: HandshakeException) -> f (displayException x), + Handler $ \(x :: IOException) -> f (displayException x) ] ping :: Message diff --git a/services/cargohold/src/CargoHold/AWS.hs b/services/cargohold/src/CargoHold/AWS.hs index bc3b60ccc2..83cbb168dc 100644 --- a/services/cargohold/src/CargoHold/AWS.hs +++ b/services/cargohold/src/CargoHold/AWS.hs @@ -175,7 +175,7 @@ exec env request = do Left err -> do Logger.info env.logger $ Log.field "remote" (Log.val "S3") - ~~ Log.msg (show err) + ~~ Log.msg (displayException err) ~~ Log.msg (show req) -- We re-throw the error, but distinguish between user errors and server -- errors. Logging it here also gives us the request that caused it. @@ -201,7 +201,7 @@ execStream env request = do Left err -> do Logger.info env.logger $ Log.field "remote" (Log.val "S3") - ~~ Log.msg (show err) + ~~ Log.msg (displayException err) ~~ Log.msg (show req) -- We just re-throw the error, but logging it here also gives us the request -- that caused it. @@ -224,7 +224,7 @@ execCatch env request = do Left err -> do Log.info $ Log.field "remote" (Log.val "S3") - ~~ Log.msg (show err) + ~~ Log.msg (displayException err) ~~ Log.msg (show req) pure Nothing Right r -> pure $ Just r diff --git a/services/federator/src/Federator/Interpreter.hs b/services/federator/src/Federator/Interpreter.hs index 31c6f91394..7d21e74380 100644 --- a/services/federator/src/Federator/Interpreter.hs +++ b/services/federator/src/Federator/Interpreter.hs @@ -209,4 +209,4 @@ getFederationDomainConfigs env = do clientEnv = mkClientEnv mgr baseurl FedUp.getFederationDomainConfigs clientEnv >>= \case Right v -> pure v - Left e -> error $ show e + Left e -> error $ displayException e diff --git a/services/federator/test/unit/Test/Federator/Client.hs b/services/federator/test/unit/Test/Federator/Client.hs index fa0ce039fb..8bc976fe6a 100644 --- a/services/federator/test/unit/Test/Federator/Client.hs +++ b/services/federator/test/unit/Test/Federator/Client.hs @@ -221,7 +221,7 @@ testClientConnectionError = do result <- runFederatorClient env (fedClient @'Brig @"get-user-by-handle" handle) case result of Left (FederatorClientHTTP2Error (FederatorClientConnectionError _)) -> pure () - Left x -> assertFailure $ "Expected connection error, got: " <> show x + Left x -> assertFailure $ "Expected connection error, got: " <> displayException x Right _ -> assertFailure "Expected connection with the server to fail" testResponseHeaders :: IO () diff --git a/services/federator/test/unit/Test/Federator/Options.hs b/services/federator/test/unit/Test/Federator/Options.hs index 137b6d411e..ffb63d7977 100644 --- a/services/federator/test/unit/Test/Federator/Options.hs +++ b/services/federator/test/unit/Test/Federator/Options.hs @@ -136,7 +136,7 @@ testSettings = Left e -> assertFailure $ "expected invalid client certificate exception, got: " - <> show e + <> displayException e Right _ -> assertFailure "expected failure for non-existing client certificate, got success", testCase "failToStartWithInvalidServerCredentials" failToStartWithInvalidServerCredentials, @@ -158,7 +158,7 @@ testSettings = Left e -> assertFailure $ "expected invalid client certificate exception, got: " - <> show e + <> displayException e Right _ -> assertFailure "expected failure for invalid private key, got success" ] @@ -184,7 +184,7 @@ failToStartWithInvalidServerCredentials = do Left e -> assertFailure $ "expected invalid client certificate exception, got: " - <> show e + <> displayException e Right _ -> assertFailure "expected failure for invalid client certificate, got success" diff --git a/services/galley/src/Galley/API/Query.hs b/services/galley/src/Galley/API/Query.hs index 610c79be94..7d3e758030 100644 --- a/services/galley/src/Galley/API/Query.hs +++ b/services/galley/src/Galley/API/Query.hs @@ -354,7 +354,7 @@ getRemoteConversationsWithFailures lusr convs = do handleFailure (Left (rcids, e)) = do P.warn $ Logger.msg ("Error occurred while fetching remote conversations" :: ByteString) - . Logger.field "error" (show e) + . Logger.field "error" (displayException e) pure . Left $ failedGetConversationRemotely (sequenceA rcids) e handleFailure (Right c) = pure . Right . traverse (.convs) $ c @@ -606,8 +606,7 @@ getSelfMember lusr cnv = do pure $ Just $ conv.cnvMembers.cmSelf getLocalSelf :: - ( Member ConversationStore r - ) => + (Member ConversationStore r) => Local UserId -> ConvId -> Sem r (Maybe Public.Member) diff --git a/services/galley/src/Galley/External/LegalHoldService/Internal.hs b/services/galley/src/Galley/External/LegalHoldService/Internal.hs index 77f77b0519..eac3a0d010 100644 --- a/services/galley/src/Galley/External/LegalHoldService/Internal.hs +++ b/services/galley/src/Galley/External/LegalHoldService/Internal.hs @@ -59,7 +59,7 @@ makeVerifiedRequestWithManager mgr verifyFingerprints fpr (HttpsUrl url) reqBuil . Bilge.secure . prependPath (uriPath url) errHandler e = do - Log.info . Log.msg $ "error making request to legalhold service: " <> show e + Log.info . Log.msg $ "error making request to legalhold service: " <> displayException e throwM (legalHoldServiceUnavailable e) prependPath :: ByteString -> Http.Request -> Http.Request prependPath pth req = req {Http.path = pth Http.path req} diff --git a/services/galley/test/integration/API/Teams/LegalHold/Util.hs b/services/galley/test/integration/API/Teams/LegalHold/Util.hs index b11611e842..39c18a415b 100644 --- a/services/galley/test/integration/API/Teams/LegalHold/Util.hs +++ b/services/galley/test/integration/API/Teams/LegalHold/Util.hs @@ -515,7 +515,7 @@ assertMatchChan c match = go [] match n refill buf `catchAll` \e -> case asyncExceptionFromException e of - Just x -> error $ show (x :: SomeAsyncException) + Just x -> error $ displayException (x :: SomeAsyncException) Nothing -> go (n : buf) Nothing -> do refill buf @@ -550,8 +550,7 @@ errWith wantStatus wantBody rsp = liftIO $ do assertEqual "" wantStatus (statusCode rsp) assertBool (show $ responseBody rsp) - ( maybe False wantBody (responseJsonMaybe rsp) - ) + (maybe False wantBody (responseJsonMaybe rsp)) ------------------------------------ diff --git a/services/gundeck/src/Gundeck/Push/Native.hs b/services/gundeck/src/Gundeck/Push/Native.hs index bc6b414bbb..a7ac2069dd 100644 --- a/services/gundeck/src/Gundeck/Push/Native.hs +++ b/services/gundeck/src/Gundeck/Push/Native.hs @@ -310,5 +310,5 @@ logError a m exn = Log.err $ field "user" (toByteString (a ^. addrUser)) ~~ field "arn" (toText (a ^. addrEndpoint)) - ~~ field "error" (show exn) + ~~ field "error" (displayException exn) ~~ msg m diff --git a/services/gundeck/src/Gundeck/Push/Websocket.hs b/services/gundeck/src/Gundeck/Push/Websocket.hs index 43dba86e9c..562bcb1073 100644 --- a/services/gundeck/src/Gundeck/Push/Websocket.hs +++ b/services/gundeck/src/Gundeck/Push/Websocket.hs @@ -125,7 +125,7 @@ logBadCannons (uri, (err, prcs)) = do ~~ Log.field "created_at" (ms $ createdAt prc) ~~ Log.field "cannon_uri" (show uri) ~~ Log.field "resource_target" (show $ resource prc) - ~~ Log.field "http_exception" (intercalate " | " . lines . show $ err) + ~~ Log.field "http_exception" (intercalate " | " . lines . displayException $ err) ~~ Log.msg (val "WebSocket presence unreachable: ") logPrcsGone :: (Log.MonadLogger m) => Presence -> m () @@ -327,7 +327,7 @@ push notif (toList -> tgts) originUser originConn conns = do <$> runWithDefaultRedis (Presence.listAll (view targetUser <$> tgts)) noPresences exn = do Log.err $ - Log.field "error" (show exn) + Log.field "error" (displayException exn) ~~ Log.msg (val "Failed to get presences.") pure [] filterByClient = map $ \(tgt, ps) -> diff --git a/services/gundeck/src/Gundeck/Redis.hs b/services/gundeck/src/Gundeck/Redis.hs index 5a8ba319ca..17e1f2e317 100644 --- a/services/gundeck/src/Gundeck/Redis.hs +++ b/services/gundeck/src/Gundeck/Redis.hs @@ -85,8 +85,8 @@ connectRobust l retryStrategy connectLowLevel = do const $ Catch.Handler (\(e :: IOException) -> logEx (Log.err l) e "network error when connecting to Redis" >> pure True) ] . const -- ignore RetryStatus - logEx :: (Show e) => ((Msg -> Msg) -> IO ()) -> e -> ByteString -> IO () - logEx lLevel e description = lLevel $ Log.msg (Log.val description) . Log.field "error" (show e) + logEx :: (Exception e) => ((Msg -> Msg) -> IO ()) -> e -> ByteString -> IO () + logEx lLevel e description = lLevel $ Log.msg (Log.val description) . Log.field "error" (displayException e) -- | Run a 'Redis' action through a 'RobustConnection'. -- @@ -107,7 +107,7 @@ runRobust mvar action = retry $ do . const -- ignore RetryStatus logAndHandle (Handler handler) _ = Handler $ \e -> do - LogClass.err $ Log.msg (Log.val "Redis connection failed") . Log.field "error" (show e) + LogClass.err $ Log.msg (Log.val "Redis connection failed") . Log.field "error" (displayException e) handler e data PingException = PingException Reply deriving (Show) diff --git a/services/gundeck/src/Gundeck/ThreadBudget/Internal.hs b/services/gundeck/src/Gundeck/ThreadBudget/Internal.hs index 89595b9d51..44d7953c93 100644 --- a/services/gundeck/src/Gundeck/ThreadBudget/Internal.hs +++ b/services/gundeck/src/Gundeck/ThreadBudget/Internal.hs @@ -308,5 +308,5 @@ safeForever :: safeForever action = forever $ action `catchAny` \exc -> do - LC.err $ "error" LC..= show exc LC.~~ LC.msg (LC.val "watchThreadBudgetState: crashed; retrying") + LC.err $ "error" LC..= displayException exc LC.~~ LC.msg (LC.val "watchThreadBudgetState: crashed; retrying") threadDelay 60000000 -- pause to keep worst-case noise in logs manageable diff --git a/services/proxy/src/Proxy/API/Public.hs b/services/proxy/src/Proxy/API/Public.hs index c374a47f77..5b7e01a4d7 100644 --- a/services/proxy/src/Proxy/API/Public.hs +++ b/services/proxy/src/Proxy/API/Public.hs @@ -134,7 +134,7 @@ proxy qparam keyname reroute path phost rq k = do onUpstreamError :: (Proxy () -> IO a) -> SomeException -> p -> (Response -> IO b) -> IO b onUpstreamError runInIO x _ next = do - void . runInIO $ Logger.warn (msg (val "gateway error") ~~ field "error" (show x)) + void . runInIO $ Logger.warn (msg (val "gateway error") ~~ field "error" (displayException x)) next (errorRs error502) waiProxyResponse :: Env -> Request -> ProxyDest -> WaiProxyResponse diff --git a/services/spar/src/Spar/Sem/SAML2/Library.hs b/services/spar/src/Spar/Sem/SAML2/Library.hs index 78e8c08c3c..7ca06008ff 100644 --- a/services/spar/src/Spar/Sem/SAML2/Library.hs +++ b/services/spar/src/Spar/Sem/SAML2/Library.hs @@ -59,7 +59,7 @@ wrapMonadClientSPImpl action = . SAML.CustomError . SparCassandraError . LText.pack - . show @SomeException + . displayException @SomeException ) instance (Member (Final IO) r) => Catch.MonadThrow (SPImpl r) where diff --git a/services/spar/src/Spar/Sem/Utils.hs b/services/spar/src/Spar/Sem/Utils.hs index 381b288171..0cac0ec9db 100644 --- a/services/spar/src/Spar/Sem/Utils.hs +++ b/services/spar/src/Spar/Sem/Utils.hs @@ -64,7 +64,7 @@ interpretClientToIO ctx = interpret $ \case . SAML.CustomError . SparCassandraError . LText.pack - . show @SomeException + . displayException @SomeException pure $ action' `Catch.catch` \e -> handler' $ e <$ st ttlErrorToSparError :: (Member (Error SparError) r) => Sem (Error TTLError ': r) a -> Sem r a diff --git a/tools/entreprise-provisioning/default.nix b/tools/entreprise-provisioning/default.nix index b2e1cd807a..ac8d086310 100644 --- a/tools/entreprise-provisioning/default.nix +++ b/tools/entreprise-provisioning/default.nix @@ -23,6 +23,7 @@ , types-common , uuid , vector +, wai-utilities , wire-api }: mkDerivation { @@ -46,6 +47,7 @@ mkDerivation { types-common uuid vector + wai-utilities wire-api ]; testHaskellDepends = [ diff --git a/tools/entreprise-provisioning/entreprise-provisioning.cabal b/tools/entreprise-provisioning/entreprise-provisioning.cabal index fa89078a1b..61f914ce51 100644 --- a/tools/entreprise-provisioning/entreprise-provisioning.cabal +++ b/tools/entreprise-provisioning/entreprise-provisioning.cabal @@ -37,6 +37,7 @@ executable entreprise-provisioning , types-common , uuid , vector + , wai-utilities , wire-api ghc-options: diff --git a/tools/entreprise-provisioning/src/API.hs b/tools/entreprise-provisioning/src/API.hs index 90bca4861b..f17908a414 100644 --- a/tools/entreprise-provisioning/src/API.hs +++ b/tools/entreprise-provisioning/src/API.hs @@ -34,6 +34,7 @@ import Data.Vector qualified as V import Imports import Network.HTTP.Client import Network.HTTP.Types.Status +import Network.Wai.Utilities.Exception (displayExceptionNoBacktrace) import Types import Wire.API.Conversation import Wire.API.Conversation.Role (roleNameWireAdmin) @@ -85,7 +86,7 @@ createChannel manager (ApiUrl apiUrl) (Token token) userId teamId channelName = result <- try $ httpLbs request manager case result of Left (e :: HttpException) -> - pure $ Left $ ErrorDetail 0 (object ["error" .= show e]) + pure $ Left $ ErrorDetail 0 (object ["error" .= displayExceptionNoBacktrace e]) Right resp -> let respStatus = statusCode (responseStatus resp) in case respStatus of @@ -130,7 +131,7 @@ associateChannelsToGroup manager (ApiUrl apiUrl) (Token token) userId groupId co result <- try $ httpLbs request manager case result of Left (e :: HttpException) -> - pure $ Left $ ErrorDetail 0 (object ["error" .= show e]) + pure $ Left $ ErrorDetail 0 (object ["error" .= displayExceptionNoBacktrace e]) Right resp -> case statusCode (responseStatus resp) of 200 -> pure $ Right () diff --git a/tools/stern/src/Stern/API.hs b/tools/stern/src/Stern/API.hs index db21771a9a..98e262a653 100644 --- a/tools/stern/src/Stern/API.hs +++ b/tools/stern/src/Stern/API.hs @@ -52,6 +52,7 @@ import Imports hiding (head) import Network.HTTP.Types import Network.Wai import Network.Wai.Utilities as Wai +import Network.Wai.Utilities.Exception (displayExceptionNoBacktrace) import Network.Wai.Utilities.Server import Network.Wai.Utilities.Server qualified as Server import Servant (NoContent (NoContent), ServerT, (:<|>) (..)) @@ -460,10 +461,10 @@ getUserData uid mMaxConvs mMaxNotifs = do -- galeb consent <- (Intra.getUserConsentValue uid <&> toJSON @ConsentValue) - `catchE` (pure . String . T.pack . show) + `catchE` (pure . String . T.pack . displayExceptionNoBacktrace) consentLog <- (Intra.getUserConsentLog uid <&> toJSON @ConsentLog) - `catchE` (pure . String . T.pack . show) + `catchE` (pure . String . T.pack . displayExceptionNoBacktrace) let em = userEmail account marketo <- do let noEmail = MarketoResult $ KeyMap.singleton "results" emptyArray @@ -471,7 +472,7 @@ getUserData uid mMaxConvs mMaxNotifs = do (pure $ toJSON noEmail) ( \e -> (Intra.getMarketoResult e <&> toJSON) - `catchE` (pure . String . T.pack . show) + `catchE` (pure . String . T.pack . displayExceptionNoBacktrace) ) em pure . UserMetaInfo . KeyMap.fromList $ diff --git a/tools/stern/src/Stern/Intra.hs b/tools/stern/src/Stern/Intra.hs index bae73c12ca..6daee4beff 100644 --- a/tools/stern/src/Stern/Intra.hs +++ b/tools/stern/src/Stern/Intra.hs @@ -655,7 +655,7 @@ catchRpcErrors action = ExceptT $ catch (Right <$> action) catchRPCException catchRPCException :: RPCException -> App (Either Error a) catchRPCException rpcE = do Log.err $ rpcExceptionMsg rpcE - pure . Left $ mkError status500 "io-error" (pack $ show rpcE) + pure . Left $ mkError status500 "io-error" (pack $ displayExceptionNoBacktrace rpcE) getTeamData :: TeamId -> Handler TeamData getTeamData tid = do