WIP: Migrate displayException calls

Drop the backtraces when the resulting string is used in HTTP response
bodies.

Author: supersven

libs/wai-utilities/src/Network/Wai/Utilities/Exception.hs

@@ -0,0 +1,15 @@
+{-# LANGUAGE ImplicitParams #-}
+
+module Network.Wai.Utilities.Exception where
+
+import Control.Exception
+import Imports
+
+-- | `displayException` with empty `ExceptionContext`
+--
+-- Starting with GHC 9.10, exceptions carry a context that contains backtraces.
+-- Displaying these  is not always desired; e.g. for HTTP response bodies.
+displayExceptionNoBacktrace :: (Exception e) => e -> String
+displayExceptionNoBacktrace = trim . displayException . toException
+  where
+    trim = (dropWhileEnd isSpace) . (dropWhile isSpace)

libs/wai-utilities/wai-utilities.cabal

@@ -65,6 +65,7 @@ library
   exposed-modules:
     Network.Wai.Utilities
     Network.Wai.Utilities.Error
+    Network.Wai.Utilities.Exception
     Network.Wai.Utilities.Headers
     Network.Wai.Utilities.JSONResponse
     Network.Wai.Utilities.MockServer

libs/wire-api-federation/src/Wire/API/Federation/Error.hs

@@ -14,6 +14,7 @@
 --
 -- You should have received a copy of the GNU Affero General Public License along
 -- with this program. If not, see <https://www.gnu.org/licenses/>.
+{-# LANGUAGE ImplicitParams #-}
 
 -- | Map federation errors to client-facing errors.
 --
@@ -95,6 +96,7 @@ import Network.HTTP.Types.Status
 import Network.HTTP.Types.Status qualified as HTTP
 import Network.HTTP2.Client qualified as HTTP2
 import Network.Wai.Utilities.Error qualified as Wai
+import Network.Wai.Utilities.Exception
 import OpenSSL.Session (SomeSSLException)
 import Servant.Client
 import Wire.API.Error
@@ -227,21 +229,21 @@ federationRemoteHTTP2Error target path = \case
     ( Wai.mkError
         unexpectedFederationResponseStatus
         "federation-http2-error"
-        (LT.pack (displayException e))
+        (LT.pack (displayExceptionNoBacktrace e))
     )
       & addErrData
   (FederatorClientTLSException e) ->
     ( Wai.mkError
         (HTTP.mkStatus 525 "SSL Handshake Failure")
         "federation-tls-error"
-        (LT.pack (displayException e))
+        (LT.pack (displayExceptionNoBacktrace e))
     )
       & addErrData
   (FederatorClientConnectionError e) ->
     ( Wai.mkError
         federatorConnectionRefusedStatus
         "federation-connection-refused"
-        (LT.pack (displayException e))
+        (LT.pack (displayExceptionNoBacktrace e))
     )
       & addErrData
   where
@@ -259,12 +261,12 @@ federationClientHTTP2Error (FederatorClientConnectionError e) =
   Wai.mkError
     HTTP.status500
     "federation-not-available"
-    (LT.pack (displayException e))
+    (LT.pack (displayExceptionNoBacktrace e))
 federationClientHTTP2Error e =
   Wai.mkError
     HTTP.status500
     "federation-local-error"
-    (LT.pack (displayException e))
+    (LT.pack (displayExceptionNoBacktrace e))
 
 federationRemoteResponseError :: SrvTarget -> Text -> HTTP.Status -> LByteString -> Wai.Error
 federationRemoteResponseError target path status body =
@@ -310,7 +312,7 @@ federationServantErrorToWai (UnsupportedContentType mediaType res) =
         <> LT.pack (show mediaType)
     )
 federationServantErrorToWai (ConnectionError e) =
-  federationUnavailable . T.pack . displayException $ e
+  federationUnavailable . T.pack . displayExceptionNoBacktrace $ e
 
 federationErrorContentType :: ResponseF a -> LT.Text
 federationErrorContentType =

libs/wire-api/src/Wire/API/MLS/Group/Serialisation.hs

@@ -36,6 +36,7 @@ import Data.Text qualified as T
 import Data.Text.Encoding qualified as T
 import Data.UUID qualified as UUID
 import Imports
+import Network.Wai.Utilities.Exception
 import Web.HttpApiData (FromHttpApiData (parseHeader))
 import Wire.API.Conversation
 import Wire.API.MLS.Group
@@ -73,7 +74,7 @@ convToGroupId parts = GroupId . L.toStrict . runPut $ do
 groupIdToConv :: GroupId -> Either String GroupIdParts
 groupIdToConv gid = do
   (rem', _, (ct, conv, gen)) <- first (\(_, _, msg) -> msg) $ runGetOrFail readConv (L.fromStrict (unGroupId gid))
-  domain <- first displayException . T.decodeUtf8' . L.toStrict $ rem'
+  domain <- first displayExceptionNoBacktrace . T.decodeUtf8' . L.toStrict $ rem'
   pure
     GroupIdParts
       { convType = toEnum $ fromIntegral ct,

services/brig/src/Brig/Provider/RPC.hs

@@ -14,6 +14,7 @@
 --
 -- You should have received a copy of the GNU Affero General Public License along
 -- with this program. If not, see <https://www.gnu.org/licenses/>.
+{-# LANGUAGE ImplicitParams #-}
 
 -- | RPCs towards service providers.
 module Brig.Provider.RPC
@@ -46,6 +47,7 @@ import Imports
 import Network.HTTP.Client qualified as Http
 import Network.HTTP.Types.Method
 import Network.HTTP.Types.Status
+import Network.Wai.Utilities.Exception
 import Ssl.Util (withVerifiedSslConnection)
 import System.Logger.Class (MonadLogger, field, msg, val, (~~))
 import System.Logger.Class qualified as Log
@@ -98,7 +100,7 @@ createBot scon new = do
       extReq scon ["bots"]
         . method POST
         . Bilge.json new
-    onExc ex = lift (extLogError scon ex) >> throwE (ServiceUnavailableWith $ displayException ex)
+    onExc ex = lift (extLogError scon ex) >> throwE (ServiceUnavailableWith $ displayExceptionNoBacktrace ex)
 
 extReq :: ServiceConn -> [ByteString] -> Request -> Request
 extReq scon ps =

services/galley/src/Galley/API/Federation.hs

@@ -64,6 +64,7 @@ import Galley.Types.Conversations.Members
 import Galley.Types.Conversations.One2One
 import Galley.Types.UserList (UserList (UserList))
 import Imports
+import Network.Wai.Utilities.Exception
 import Polysemy
 import Polysemy.Error
 import Polysemy.Input
@@ -330,7 +331,7 @@ leaveConversation requestingDomain lc = do
 
       pure $ LeaveConversationResponse (Right ())
   where
-    internalErr = InternalErrorWithDescription . LT.pack . displayException
+    internalErr = InternalErrorWithDescription . LT.pack . displayExceptionNoBacktrace
 
 -- FUTUREWORK: report errors to the originating backend
 -- FUTUREWORK: error handling for missing / mismatched clients

services/galley/src/Galley/Keys.hs

@@ -38,6 +38,7 @@ import Data.PEM
 import Data.Proxy
 import Data.X509
 import Imports
+import Network.Wai.Utilities.Exception
 import Wire.API.MLS.CipherSuite
 import Wire.API.MLS.Keys
 
@@ -119,7 +120,7 @@ decodeEcdsaKeyPair bytes = do
   pem <- expectOne "private key" pems
   let content = pemContent pem
   -- parse outer pkcs8 container as BER
-  asn1 <- first displayException (decodeASN1' BER content)
+  asn1 <- first displayExceptionNoBacktrace (decodeASN1' BER content)
   (oid, key) <- case asn1 of
     [ Start Sequence,
       IntVal _version,
@@ -139,7 +140,7 @@ decodeEcdsaKeyPair bytes = do
     )
     $ guard (oid == curveOID @c)
   -- parse key bytestring as BER again, this should be in the format of rfc5915
-  asn1' <- first displayException (decodeASN1' BER key)
+  asn1' <- first displayExceptionNoBacktrace (decodeASN1' BER key)
   (privBS, pubBS) <- case asn1' of
     [ Start Sequence,
       IntVal _version,
@@ -151,10 +152,10 @@ decodeEcdsaKeyPair bytes = do
       ] -> pure (priv, pub)
     _ -> Left "invalid ECDSA key format: expected rfc5915 private key format"
   priv <-
-    first displayException . eitherCryptoError $
+    first displayExceptionNoBacktrace . eitherCryptoError $
       ECDSA.decodePrivate curve privBS
   pub <-
-    first displayException . eitherCryptoError $
+    first displayExceptionNoBacktrace . eitherCryptoError $
       ECDSA.decodePublic curve pubBS
   pure (priv, pub)
 
@@ -165,7 +166,7 @@ decodeEd25519PrivateKey bytes = do
   pems <- pemParseLBS bytes
   pem <- expectOne "private key" pems
   let content = pemContent pem
-  asn1 <- first displayException (decodeASN1' BER content)
+  asn1 <- first displayExceptionNoBacktrace (decodeASN1' BER content)
   (priv, remainder) <- fromASN1 asn1
   expectEmpty remainder
   case priv of

services/spar/src/Spar/Scim.hs

@@ -67,6 +67,7 @@ import qualified Data.Text as T
 import qualified Data.Text.Encoding as T
 import Data.Text.Encoding.Error
 import Imports
+import Network.Wai.Utilities.Exception
 import Polysemy
 import Polysemy.Error (Error, fromExceptionSem, runError, throw, try)
 import Polysemy.Input (Input)
@@ -157,7 +158,7 @@ apiScim =
           -- We caught an exception that's not a Spar exception at all. It is wrapped into
           -- Scim.serverError.
           throw . SAML.CustomError . SparScimError $
-            Scim.serverError (T.pack (displayException someException))
+            Scim.serverError (T.pack (displayExceptionNoBacktrace someException))
         Right (Left err@(SAML.CustomError (SparScimError _))) ->
           -- We caught a 'SparScimError' exception. It is left as-is.
           throw err

tools/stern/src/Stern/Intra.hs

@@ -101,6 +101,7 @@ import Network.HTTP.Types (urlEncode)
 import Network.HTTP.Types.Method
 import Network.HTTP.Types.Status hiding (statusCode, statusMessage)
 import Network.Wai.Utilities (Error (..), mkError)
+import Network.Wai.Utilities.Exception
 import Servant.API
 import Servant.Client qualified as SC
 import Servant.Server qualified as SS
@@ -1063,7 +1064,7 @@ runClientToHandler :: SC.ClientM a -> Handler a
 runClientToHandler client = do
   clientEnv <- asks (.brigServantClientEnv)
   res <- liftIO $ SC.runClientM client clientEnv
-  either (throwE . mkError status400 "servant-client-error" . LT.pack . displayException) pure res
+  either (throwE . mkError status400 "servant-client-error" . LT.pack . displayExceptionNoBacktrace) pure res
 
 domRegLock :: Domain -> SC.ClientM NoContent
 domRegUnlock :: Domain -> SC.ClientM NoContent