Upgrade GHC from 9.8 to 9.10

libs/bilge/bilge.cabal

@@ -98,6 +98,7 @@ library
     , uri-bytestring
     , wai
     , wai-extra
+    , wai-utilities
     , wire-otel
 
   default-language:   GHC2021

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";

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 <!! aa = do
     msg (i, Just m) = printf "%2d: " i ++ err m
     msg _ = ""
     printErr :: SomeException -> m a
-    printErr e = error $ title "Error executing request: " ++ err (show e)
+    printErr e = error $ title "Error executing request: " ++ err (displayExceptionNoBacktrace e)
 
 -- | Like '<!!' but discards the 'Response'.
 (!!!) ::

libs/bilge/src/Bilge/RPC.hs

@@ -39,6 +39,7 @@ import Data.Text.Lazy (pack)
 import Data.Text.Lazy qualified as T
 import Imports hiding (log)
 import Network.HTTP.Client qualified as HTTP
+import Network.Wai.Utilities.Exception (displayExceptionNoBacktrace)
 import System.Logger.Class
 import Wire.OpenTelemetry (withClientInstrumentation)
 
@@ -100,7 +101,7 @@ rpc' sys r f = do
 
 rpcExceptionMsg :: RPCException -> 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

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

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/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

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,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/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

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

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

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

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]

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
 

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

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

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

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 ()

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"
 

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)

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}

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))
 
 ------------------------------------
 

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

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) ->