WIP: Migrate displayException calls

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

Author: supersven

hls.json

@@ -0,0 +1,163 @@
+{
+    "cabalFormattingProvider": "cabal-gild",
+    "checkParents": "CheckOnSave",
+    "checkProject": false,
+    "formattingProvider": "ormolu",
+    "maxCompletions": 40,
+    "plugin": {
+        "alternateNumberFormat": {
+            "globalOn": true
+        },
+        "cabal": {
+            "codeActionsOn": true,
+            "completionOn": true,
+            "diagnosticsOn": true,
+            "hoverOn": true,
+            "symbolsOn": true
+        },
+        "cabal-fmt": {
+            "config": {
+                "path": "cabal-fmt"
+            }
+        },
+        "cabal-gild": {
+            "config": {
+                "path": "cabal-gild"
+            }
+        },
+        "cabalHaskellIntegration": {
+            "globalOn": true
+        },
+        "callHierarchy": {
+            "globalOn": true
+        },
+        "changeTypeSignature": {
+            "globalOn": true
+        },
+        "class": {
+            "codeActionsOn": true,
+            "codeLensOn": true
+        },
+        "eval": {
+            "config": {
+                "diff": true,
+                "exception": false
+            },
+            "globalOn": true
+        },
+        "explicit-fields": {
+            "codeActionsOn": true,
+            "inlayHintsOn": true
+        },
+        "explicit-fixity": {
+            "globalOn": true
+        },
+        "fourmolu": {
+            "config": {
+                "external": false,
+                "path": "fourmolu"
+            }
+        },
+        "gadt": {
+            "globalOn": true
+        },
+        "ghcide-code-actions-bindings": {
+            "globalOn": true
+        },
+        "ghcide-code-actions-fill-holes": {
+            "globalOn": true
+        },
+        "ghcide-code-actions-imports-exports": {
+            "globalOn": true
+        },
+        "ghcide-code-actions-type-signatures": {
+            "globalOn": true
+        },
+        "ghcide-completions": {
+            "config": {
+                "autoExtendOn": true,
+                "snippetsOn": true
+            },
+            "globalOn": true
+        },
+        "ghcide-hover-and-symbols": {
+            "hoverOn": true,
+            "symbolsOn": true
+        },
+        "ghcide-type-lenses": {
+            "config": {
+                "mode": "always"
+            },
+            "globalOn": true
+        },
+        "hlint": {
+            "codeActionsOn": true,
+            "config": {
+                "flags": []
+            },
+            "diagnosticsOn": true
+        },
+        "importLens": {
+            "codeActionsOn": true,
+            "codeLensOn": false,
+            "inlayHintsOn": true
+        },
+        "moduleName": {
+            "globalOn": true
+        },
+        "ormolu": {
+            "config": {
+                "external": false
+            }
+        },
+        "overloaded-record-dot": {
+            "globalOn": true
+        },
+        "pragmas-completion": {
+            "globalOn": true
+        },
+        "pragmas-disable": {
+            "globalOn": true
+        },
+        "pragmas-suggest": {
+            "globalOn": true
+        },
+        "qualifyImportedNames": {
+            "globalOn": true
+        },
+        "rename": {
+            "config": {
+                "crossModule": false
+            },
+            "globalOn": true
+        },
+        "retrie": {
+            "globalOn": true
+        },
+        "semanticTokens": {
+            "config": {
+                "classMethodToken": "method",
+                "classToken": "class",
+                "dataConstructorToken": "enumMember",
+                "functionToken": "function",
+                "moduleToken": "namespace",
+                "operatorToken": "operator",
+                "patternSynonymToken": "macro",
+                "recordFieldToken": "property",
+                "typeConstructorToken": "enum",
+                "typeFamilyToken": "interface",
+                "typeSynonymToken": "type",
+                "typeVariableToken": "typeParameter",
+                "variableToken": "variable"
+            },
+            "globalOn": true
+        },
+        "splice": {
+            "globalOn": true
+        },
+        "stan": {
+            "globalOn": false
+        }
+    },
+    "sessionLoading": "singleComponent"
+}

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

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 $ HS.X509Data (HS.X509Certificate cert :| []) :| []
@@ -224,16 +225,16 @@ 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
 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 <-

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

@@ -39,6 +39,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
@@ -116,7 +117,7 @@ getParts = do
       eDomain <-
         T.decodeUtf8' . L.toStrict
           <$> getRemainingLazyByteString
-      domain <- either (fail . displayException) pure eDomain
+      domain <- either (fail . displayExceptionNoBacktrace) pure eDomain
       pure
         GroupIdParts
           { convType,
@@ -148,7 +149,7 @@ getDomain = do
   len <- fromIntegral <$> getWord16be
   domain <- T.decodeUtf8' <$> getByteString len
   case domain of
-    Left e -> fail (displayException e)
+    Left e -> fail (displayExceptionNoBacktrace e)
     Right d -> pure (Domain d)
 
 newGroupId :: ConvType -> Qualified ConvOrSubConvId -> GroupId

libs/wire-api/src/Wire/API/Team/Export.hs

@@ -35,6 +35,7 @@ import Data.Time.Clock
 import Data.Time.Format
 import Data.Vector (fromList)
 import Imports
+import Network.Wai.Utilities.Exception
 import Test.QuickCheck
 import Wire.API.Team.Role (Role)
 import Wire.API.User (AccountStatus (..), Name)
@@ -150,7 +151,7 @@ parseByteString bstr =
 
 parseUTCTime :: ByteString -> Parser UTCTime
 parseUTCTime b = do
-  s <- either (fail . displayException) pure $ T.decodeUtf8' b
+  s <- either (fail . displayExceptionNoBacktrace) pure $ T.decodeUtf8' b
   parseTimeM False defaultTimeLocale timestampFormat (T.unpack s)
 
 parseAccountStatus :: ByteString -> Parser AccountStatus

libs/wire-subsystems/src/Wire/Error.hs

@@ -10,6 +10,7 @@ import Hasql.Pool
 import Imports
 import Network.HTTP.Types
 import Network.Wai.Utilities.Error qualified as Wai
+import Network.Wai.Utilities.Exception
 import Network.Wai.Utilities.JSONResponse
 
 -- | Error thrown to the user
@@ -49,6 +50,6 @@ postgresUsageErrorToHttpError err = case err of
     -- return "404 not found", not "database crashed"?
     -- The problem is that the SessionError is not typed to easily be parsed
     -- To prevent foreign key errors we should check the foreign key constraints before inserting
-    StdError (Wai.mkError status500 "server-error" (LT.pack $ "postgres: " <> show err))
-  ConnectionUsageError _ -> StdError (Wai.mkError status500 "server-error" (LT.pack $ "postgres: " <> show err))
-  AcquisitionTimeoutUsageError -> StdError (Wai.mkError status500 "server-error" (LT.pack $ "postgres: " <> show err))
+    StdError (Wai.mkError status500 "server-error" (LT.pack $ "postgres: " <> displayExceptionNoBacktrace err))
+  ConnectionUsageError _ -> StdError (Wai.mkError status500 "server-error" (LT.pack $ "postgres: " <> displayExceptionNoBacktrace err))
+  AcquisitionTimeoutUsageError -> StdError (Wai.mkError status500 "server-error" (LT.pack $ "postgres: " <> displayExceptionNoBacktrace err))