diff --git a/changelog.d/1-api-changes/fed-error-wrapping b/changelog.d/1-api-changes/fed-error-wrapping new file mode 100644 index 00000000000..b61781ce796 --- /dev/null +++ b/changelog.d/1-api-changes/fed-error-wrapping @@ -0,0 +1 @@ +Improved formatting of federation errors. No extra copy of the response body, and nested errors are now part of the JSON structure, not quoted inside the message. diff --git a/integration/default.nix b/integration/default.nix index c21551bcd65..efdcfb7e040 100644 --- a/integration/default.nix +++ b/integration/default.nix @@ -53,6 +53,7 @@ , scientific , split , stm +, streaming-commons , string-conversions , tagged , temporary @@ -64,6 +65,9 @@ , unliftio , uuid , vector +, wai +, warp +, warp-tls , websockets , wire-message-proto-lens , xml @@ -124,6 +128,7 @@ mkDerivation { scientific split stm + streaming-commons string-conversions tagged temporary @@ -135,6 +140,9 @@ mkDerivation { unliftio uuid vector + wai + warp + warp-tls websockets wire-message-proto-lens xml diff --git a/integration/integration.cabal b/integration/integration.cabal index df86cf50248..dd1aa46f98b 100644 --- a/integration/integration.cabal +++ b/integration/integration.cabal @@ -108,6 +108,7 @@ library Test.Client Test.Conversation Test.Demo + Test.Errors Test.Federation Test.Federator Test.MessageTimer @@ -128,6 +129,7 @@ library Testlib.Env Testlib.HTTP Testlib.JSON + Testlib.Mock Testlib.ModService Testlib.One2One Testlib.Options @@ -190,6 +192,7 @@ library , scientific , split , stm + , streaming-commons , string-conversions , tagged , temporary @@ -201,6 +204,9 @@ library , unliftio , uuid , vector + , wai + , warp + , warp-tls , websockets , wire-message-proto-lens , xml diff --git a/integration/test/Test/Errors.hs b/integration/test/Test/Errors.hs new file mode 100644 index 00000000000..54f714fac05 --- /dev/null +++ b/integration/test/Test/Errors.hs @@ -0,0 +1,54 @@ +{-# OPTIONS -Wno-ambiguous-fields #-} +module Test.Errors where + +import API.Brig +import Control.Monad.Codensity +import Control.Monad.Reader +import Data.Aeson qualified as Aeson +import Network.HTTP.Types qualified as HTTP +import Network.Wai qualified as Wai +import SetupHelpers +import Testlib.Mock +import Testlib.Prelude +import Testlib.ResourcePool + +testNestedError :: HasCallStack => App () +testNestedError = do + let innerError = + object + [ "code" .= (400 :: Int), + "label" .= "example", + "message" .= "Example remote federator failure" + ] + + resourcePool <- asks resourcePool + lowerCodensity $ do + [res] <- acquireResources 1 resourcePool + mockConfig <- do + mBase <- asks (.servicesCwdBase) + pure $ case mBase of + Just _ -> + -- when running locally, spawn a fake ingress returning an error + def + { port = Just (fromIntegral res.berNginzSslPort), + tls = True + } + Nothing -> do + -- on CI, the real federation ingress is available, so we spawn its federator upstream instead + def + { port = Just (fromIntegral res.berFederatorExternal), + tls = False + } + void $ + startMockServer mockConfig $ + codensityApp $ + \_req -> pure $ Wai.responseLBS HTTP.status400 mempty $ Aeson.encode innerError + + -- get remote user + lift $ do + user <- randomUser OwnDomain def + targetId <- randomId + let target = object ["id" .= targetId, "domain" .= res.berDomain] + bindResponse (getUser user target) $ \resp -> do + resp.status `shouldMatchInt` 533 + resp.json %. "inner" `shouldMatch` innerError diff --git a/integration/test/Testlib/Mock.hs b/integration/test/Testlib/Mock.hs new file mode 100644 index 00000000000..d7c62b5e79f --- /dev/null +++ b/integration/test/Testlib/Mock.hs @@ -0,0 +1,85 @@ +module Testlib.Mock (startMockServer, MockServerConfig (..), codensityApp) where + +import Control.Concurrent.Async +import Control.Concurrent.MVar +import Control.Exception +import Control.Monad.Codensity +import Control.Monad.Reader +import Data.Streaming.Network +import Network.Socket qualified as Socket +import Network.Wai qualified as Wai +import Network.Wai.Handler.Warp qualified as Warp +import Network.Wai.Handler.WarpTLS qualified as Warp +import Testlib.Prelude + +codensityApp :: (Wai.Request -> Codensity IO Wai.Response) -> Wai.Application +codensityApp f req = runCodensity (f req) + +data MockServerConfig = MockServerConfig + { port :: Maybe Warp.Port, + tls :: Bool + } + +instance Default MockServerConfig where + def = MockServerConfig {port = Nothing, tls = False} + +spawnServer :: Warp.Settings -> Socket.Socket -> Wai.Application -> App () +spawnServer wsettings sock app = liftIO $ Warp.runSettingsSocket wsettings sock app + +spawnTLSServer :: Warp.Settings -> Socket.Socket -> Wai.Application -> App () +spawnTLSServer wsettings sock app = do + (cert, key) <- + asks (.servicesCwdBase) <&> \case + Nothing -> + ( "/etc/wire/federator/secrets/tls.crt", + "/etc/wire/federator/secrets/tls.key" + ) + Just base -> + ( base <> "/federator/test/resources/integration-leaf.pem", + base <> "/federator/test/resources/integration-leaf-key.pem" + ) + liftIO $ Warp.runTLSSocket (Warp.tlsSettings cert key) wsettings sock app + +startMockServer :: MockServerConfig -> Wai.Application -> Codensity App Warp.Port +startMockServer config app = do + let closeSocket sock = catch (Socket.close sock) (\(_ :: SomeException) -> pure ()) + (port, sock) <- Codensity $ \k -> do + action <- appToIOKleisli k + liftIO $ + bracket + ( case config.port of + Nothing -> bindRandomPortTCP (fromString "*6") + Just n -> (n,) <$> bindPortTCP n (fromString "*6") + ) + (\(_, sock) -> closeSocket sock) + action + serverStarted <- liftIO newEmptyMVar + let wsettings = + Warp.defaultSettings + & Warp.setPort port + & Warp.setGracefulCloseTimeout2 0 + & Warp.setBeforeMainLoop (putMVar serverStarted Nothing) + + -- Action to start server in a separate thread. + startServer <- lift . appToIO $ (if config.tls then spawnTLSServer else spawnServer) wsettings sock app + let startServerAsync = do + a <- async $ do + catch startServer $ \(e :: SomeException) -> + void $ tryPutMVar serverStarted (Just e) + mException <- readMVar serverStarted + traverse_ throw mException + pure a + + Codensity $ \k -> do + action <- appToIO (k ()) + liftIO + $ bracket + startServerAsync + ( \serverAsync -> do + closeSocket sock + -- kill the thread running the server + cancel serverAsync + ) + $ const action + + pure port diff --git a/integration/test/Testlib/ModService.hs b/integration/test/Testlib/ModService.hs index 8ce5bee7867..e271bb3575d 100644 --- a/integration/test/Testlib/ModService.hs +++ b/integration/test/Testlib/ModService.hs @@ -18,7 +18,6 @@ import Control.Monad.Extra import Control.Monad.Reader import Control.Retry (fibonacciBackoff, limitRetriesByCumulativeDelay, retrying) import Data.Aeson hiding ((.=)) -import Data.Aeson.KeyMap qualified as Aeson import Data.Default import Data.Foldable import Data.Function @@ -355,19 +354,15 @@ startBackend resource overrides services = do . (addJSONObject []) checkStatus <- appToIO $ do res <- submit "POST" req - -- If we get 533 here it means federation is not avaiable between domains + -- If we get 533 here it means federation is not available between domains -- but ingress is working, since we're processing the request. let is200 = res.status == 200 - msg = case res.jsonBody of - Just (Object obj) -> - (Aeson.lookup "message" obj) - _ -> Nothing - isFedDenied = - res.status == 533 - && ( Text.isInfixOf - "federation-denied" - (Text.pack $ show msg) - ) + mInner <- lookupField res.json "inner" + isFedDenied <- case mInner of + Nothing -> pure False + Just inner -> do + label <- inner %. "label" & asString + pure $ res.status == 533 && label == "federation-denied" pure (is200 || isFedDenied) eith <- liftIO (E.try checkStatus) diff --git a/integration/test/Testlib/ResourcePool.hs b/integration/test/Testlib/ResourcePool.hs index c7483ca9478..788c3c5dda0 100644 --- a/integration/test/Testlib/ResourcePool.hs +++ b/integration/test/Testlib/ResourcePool.hs @@ -2,7 +2,6 @@ module Testlib.ResourcePool ( ResourcePool, BackendResource (..), DynamicBackendConfig (..), - backendResources, createBackendResourcePool, acquireResources, backendA, diff --git a/libs/wai-utilities/src/Network/Wai/Utilities/Error.hs b/libs/wai-utilities/src/Network/Wai/Utilities/Error.hs index 6aeb602ede2..ba7bdcf90fd 100644 --- a/libs/wai-utilities/src/Network/Wai/Utilities/Error.hs +++ b/libs/wai-utilities/src/Network/Wai/Utilities/Error.hs @@ -31,7 +31,7 @@ import Control.Error import Data.Aeson hiding (Error) import Data.Aeson.Types (Pair) import Data.Domain -import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8) +import Data.Text.Lazy.Encoding (decodeUtf8) import Imports import Network.HTTP.Types @@ -39,29 +39,28 @@ data Error = Error { code :: !Status, label :: !LText, message :: !LText, - errorData :: Maybe ErrorData + errorData :: Maybe ErrorData, + innerError :: Maybe Error } deriving (Eq, Show, Typeable) mkError :: Status -> LText -> LText -> Error -mkError c l m = Error c l m Nothing +mkError c l m = Error c l m Nothing Nothing instance Exception Error data ErrorData = FederationErrorData { federrDomain :: !Domain, - federrPath :: !Text, - federrResp :: !(Maybe LByteString) + federrPath :: !Text } deriving (Eq, Show, Typeable) instance ToJSON ErrorData where - toJSON (FederationErrorData d p b) = - object + toJSON (FederationErrorData d p) = + object $ [ "type" .= ("federation" :: Text), "domain" .= d, - "path" .= p, - "response" .= fmap decodeUtf8 b + "path" .= p ] instance FromJSON ErrorData where @@ -69,20 +68,20 @@ instance FromJSON ErrorData where FederationErrorData <$> o .: "domain" <*> o .: "path" - <*> (fmap encodeUtf8 <$> (o .: "response")) -- | Assumes UTF-8 encoding. byteStringError :: Status -> LByteString -> LByteString -> Error -byteStringError s l m = Error s (decodeUtf8 l) (decodeUtf8 m) Nothing +byteStringError s l m = mkError s (decodeUtf8 l) (decodeUtf8 m) instance ToJSON Error where - toJSON (Error c l m md) = + toJSON (Error c l m md inner) = object $ [ "code" .= statusCode c, "label" .= l, "message" .= m ] ++ maybe [] dataFields md + ++ ["inner" .= e | e <- toList inner] where dataFields :: ErrorData -> [Pair] dataFields d = ["data" .= d] @@ -94,6 +93,7 @@ instance FromJSON Error where <*> o .: "label" <*> o .: "message" <*> o .:? "data" + <*> o .:? "inner" -- FIXME: This should not live here. infixl 5 !>> diff --git a/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs b/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs index 05856b3974b..1226a363137 100644 --- a/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs +++ b/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs @@ -392,16 +392,16 @@ logJSONResponse g mr e = do | otherwise = Log.debug logErrorMsg :: Wai.Error -> Msg -> Msg -logErrorMsg (Wai.Error c l m md) = +logErrorMsg (Wai.Error c l m md inner) = field "code" (statusCode c) . field "label" l . maybe id logErrorData md . msg (val "\"" +++ m +++ val "\"") + . maybe id logErrorMsg inner where - logErrorData (Wai.FederationErrorData d p b) = + logErrorData (Wai.FederationErrorData d p) = field "domain" (domainText d) . field "path" p - . field "response" (fromMaybe "" b) logErrorMsgWithRequest :: Maybe ByteString -> Wai.Error -> Msg -> Msg logErrorMsgWithRequest mr e = diff --git a/libs/wire-api-federation/src/Wire/API/Federation/Client.hs b/libs/wire-api-federation/src/Wire/API/Federation/Client.hs index b27b833b2e7..ee42a4152d6 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/Client.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/Client.hs @@ -270,8 +270,7 @@ mkFailureResponse status domain path body { Wai.federrDomain = domain, Wai.federrPath = "/federation" - <> Text.decodeUtf8With Text.lenientDecode (LBS.toStrict path), - Wai.federrResp = pure body + <> Text.decodeUtf8With Text.lenientDecode (LBS.toStrict path) } } where diff --git a/libs/wire-api-federation/src/Wire/API/Federation/Error.hs b/libs/wire-api-federation/src/Wire/API/Federation/Error.hs index cfa99767e6c..fcf3c9adce1 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/Error.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/Error.hs @@ -83,10 +83,12 @@ module Wire.API.Federation.Error ) where -import Data.Domain (Domain (..)) +import Data.Aeson qualified as Aeson import Data.Text qualified as T import Data.Text.Encoding qualified as T +import Data.Text.Encoding.Error qualified as T import Data.Text.Lazy qualified as LT +import Data.Text.Lazy.Encoding qualified as LT import Imports import Network.HTTP.Types.Status import Network.HTTP.Types.Status qualified as HTTP @@ -207,35 +209,27 @@ federationClientErrorToWai FederatorClientVersionMismatch = "internal-error" "Endpoint version mismatch in federation client" -federationRemoteHTTP2Error :: Domain -> Text -> FederatorClientHTTP2Error -> Wai.Error -federationRemoteHTTP2Error domain path FederatorClientNoStatusCode = - let err = - Wai.mkError - unexpectedFederationResponseStatus - "federation-http2-error" - "No status code in HTTP2 response" - in err {Wai.errorData = pure $ Wai.FederationErrorData domain path Nothing} -federationRemoteHTTP2Error domain path (FederatorClientHTTP2Exception e) = - let err = - Wai.mkError - unexpectedFederationResponseStatus - "federation-http2-error" - (LT.pack (displayException e)) - in err {Wai.errorData = pure $ Wai.FederationErrorData domain path Nothing} -federationRemoteHTTP2Error domain path (FederatorClientTLSException e) = - let err = - Wai.mkError - (HTTP.mkStatus 525 "SSL Handshake Failure") - "federation-tls-error" - (LT.pack (displayException e)) - in err {Wai.errorData = pure $ Wai.FederationErrorData domain path Nothing} -federationRemoteHTTP2Error domain path (FederatorClientConnectionError e) = - let err = - Wai.mkError - federatorConnectionRefusedStatus - "federation-connection-refused" - (LT.pack (displayException e)) - in err {Wai.errorData = pure $ Wai.FederationErrorData domain path Nothing} +federationRemoteHTTP2Error :: FederatorClientHTTP2Error -> Wai.Error +federationRemoteHTTP2Error FederatorClientNoStatusCode = + Wai.mkError + unexpectedFederationResponseStatus + "federation-http2-error" + "No status code in HTTP2 response" +federationRemoteHTTP2Error (FederatorClientHTTP2Exception e) = + Wai.mkError + unexpectedFederationResponseStatus + "federation-http2-error" + (LT.pack (displayException e)) +federationRemoteHTTP2Error (FederatorClientTLSException e) = + Wai.mkError + (HTTP.mkStatus 525 "SSL Handshake Failure") + "federation-tls-error" + (LT.pack (displayException e)) +federationRemoteHTTP2Error (FederatorClientConnectionError e) = + Wai.mkError + federatorConnectionRefusedStatus + "federation-connection-refused" + (LT.pack (displayException e)) federationClientHTTP2Error :: FederatorClientHTTP2Error -> Wai.Error federationClientHTTP2Error (FederatorClientConnectionError e) = @@ -249,21 +243,25 @@ federationClientHTTP2Error e = "federation-local-error" (LT.pack (displayException e)) -federationRemoteResponseError :: Domain -> Text -> HTTP.Status -> LByteString -> Wai.Error -federationRemoteResponseError domain path status resp = - err - { Wai.errorData = pure $ Wai.FederationErrorData domain path $ pure resp +federationRemoteResponseError :: HTTP.Status -> LByteString -> Wai.Error +federationRemoteResponseError status body = + ( Wai.mkError + unexpectedFederationResponseStatus + "federation-remote-error" + ( "A remote federator failed with status code: " + <> LT.pack (show (HTTP.statusCode status)) + ) + ) + { Wai.innerError = + Just $ + fromMaybe + ( Wai.mkError + status + "unknown-error" + (LT.decodeUtf8With T.lenientDecode body) + ) + (Aeson.decode body) } - where - err = - Wai.mkError - unexpectedFederationResponseStatus - "federation-remote-error" - ( "A remote federator (" - <> LT.fromStrict domain._domainText - <> ") failed with status code " - <> LT.pack (show (HTTP.statusCode status)) - ) federationServantErrorToWai :: ClientError -> Wai.Error federationServantErrorToWai (DecodeFailure msg _) = federationInvalidBody msg diff --git a/services/federator/src/Federator/Discovery.hs b/services/federator/src/Federator/Discovery.hs index 72c95725d54..9050125e68c 100644 --- a/services/federator/src/Federator/Discovery.hs +++ b/services/federator/src/Federator/Discovery.hs @@ -45,16 +45,17 @@ data DiscoveryFailure instance Exception DiscoveryFailure instance AsWai DiscoveryFailure where - toWai e = Wai.mkError status label (LText.fromStrict (waiErrorDescription e)) + toWai e = Wai.mkError status label (LText.fromStrict (discoveryErrorDescription e)) where (status, label) = case e of DiscoveryFailureSrvNotAvailable _ -> (HTTP.status422, "invalid-domain") DiscoveryFailureDNSError _ -> (HTTP.status400, "discovery-failure") - waiErrorDescription :: DiscoveryFailure -> Text - waiErrorDescription (DiscoveryFailureSrvNotAvailable msg) = - "srv record not found: " <> Text.decodeUtf8 msg - waiErrorDescription (DiscoveryFailureDNSError msg) = - "DNS error: " <> Text.decodeUtf8 msg + +discoveryErrorDescription :: DiscoveryFailure -> Text +discoveryErrorDescription (DiscoveryFailureSrvNotAvailable msg) = + "srv record not found: " <> Text.decodeUtf8 msg +discoveryErrorDescription (DiscoveryFailureDNSError msg) = + "DNS error: " <> Text.decodeUtf8 msg data DiscoverFederator m a where DiscoverFederator :: Domain -> DiscoverFederator m (Either DiscoveryFailure SrvTarget) diff --git a/services/federator/src/Federator/Error.hs b/services/federator/src/Federator/Error.hs index 1aa496baa3b..7b6f06342d9 100644 --- a/services/federator/src/Federator/Error.hs +++ b/services/federator/src/Federator/Error.hs @@ -22,14 +22,12 @@ module Federator.Error where import Data.Aeson qualified as A -import Imports import Network.HTTP.Types.Header import Network.Wai qualified as Wai import Network.Wai.Utilities.Error qualified as Wai class AsWai e where toWai :: e -> Wai.Error - waiErrorDescription :: e -> Text errorResponse :: [Header] -> Wai.Error -> Wai.Response errorResponse hdrs e = Wai.responseLBS (Wai.code e) hdrs (A.encode e) diff --git a/services/federator/src/Federator/Error/ServerError.hs b/services/federator/src/Federator/Error/ServerError.hs index a4d971b00d7..844edaf5848 100644 --- a/services/federator/src/Federator/Error/ServerError.hs +++ b/services/federator/src/Federator/Error/ServerError.hs @@ -34,12 +34,13 @@ instance Exception ServerError instance AsWai ServerError where toWai e@InvalidRoute = - Wai.mkError HTTP.status403 "invalid-endpoint" (LText.fromStrict (waiErrorDescription e)) + Wai.mkError HTTP.status403 "invalid-endpoint" (LText.fromStrict (serverErrorDescription e)) toWai e@(UnknownComponent _) = - Wai.mkError HTTP.status403 "unknown-component" (LText.fromStrict (waiErrorDescription e)) + Wai.mkError HTTP.status403 "unknown-component" (LText.fromStrict (serverErrorDescription e)) toWai e@NoOriginDomain = - Wai.mkError HTTP.status403 "no-origin-domain" (LText.fromStrict (waiErrorDescription e)) + Wai.mkError HTTP.status403 "no-origin-domain" (LText.fromStrict (serverErrorDescription e)) - waiErrorDescription InvalidRoute = "The requested endpoint does not exist" - waiErrorDescription (UnknownComponent name) = "No such component: " <> name - waiErrorDescription NoOriginDomain = "No " <> originDomainHeaderName <> " header" +serverErrorDescription :: ServerError -> Text +serverErrorDescription InvalidRoute = "The requested endpoint does not exist" +serverErrorDescription (UnknownComponent name) = "No such component: " <> name +serverErrorDescription NoOriginDomain = "No " <> originDomainHeaderName <> " header" diff --git a/services/federator/src/Federator/MockServer.hs b/services/federator/src/Federator/MockServer.hs index 2f2fd2be656..de817f984ff 100644 --- a/services/federator/src/Federator/MockServer.hs +++ b/services/federator/src/Federator/MockServer.hs @@ -81,9 +81,6 @@ instance AsWai MockException where toWai (MockErrorResponse status message) = Wai.mkError status "mock-error" message toWai (MockUnreachableBackendErrorResponse d) = Wai.mkError HTTP.status503 "mock-error" (unreachableMsg d) - waiErrorDescription (MockErrorResponse _ message) = LText.toStrict message - waiErrorDescription (MockUnreachableBackendErrorResponse d) = - LText.toStrict . unreachableMsg $ d unreachableMsg :: Domain -> LText unreachableMsg (LText.fromStrict . domainText -> d) = diff --git a/services/federator/src/Federator/Remote.hs b/services/federator/src/Federator/Remote.hs index 3741bad1bf9..21f1443c781 100644 --- a/services/federator/src/Federator/Remote.hs +++ b/services/federator/src/Federator/Remote.hs @@ -31,10 +31,7 @@ import Control.Monad.Codensity import Data.Binary.Builder import Data.ByteString.Lazy qualified as LBS import Data.Domain -import Data.Text qualified as Text import Data.Text.Encoding (decodeUtf8) -import Data.Text.Encoding qualified as Text -import Data.Text.Encoding.Error qualified as Text import Federator.Discovery import Federator.Error import HTTP2.Client.Manager (Http2Manager) @@ -64,35 +61,10 @@ data RemoteError deriving (Show) instance AsWai RemoteError where - toWai (RemoteError target path e) = - let domain = Domain . decodeUtf8 $ target.srvTargetDomain - in federationRemoteHTTP2Error domain path e - toWai (RemoteErrorResponse target path status resp) = - let domain = Domain . decodeUtf8 $ target.srvTargetDomain - in federationRemoteResponseError domain path status resp - - waiErrorDescription (RemoteError tgt path e) = - "Error while connecting to " - <> displayTarget tgt - <> " on path " - <> path - <> ": " - <> Text.pack (displayException e) - waiErrorDescription (RemoteErrorResponse tgt path status body) = - "Federator at " - <> displayTarget tgt - <> " on path " - <> path - <> " failed with status code " - <> Text.pack (show (HTTP.statusCode status)) - <> ": " - <> Text.decodeUtf8With Text.lenientDecode (LBS.toStrict body) - -displayTarget :: SrvTarget -> Text -displayTarget (SrvTarget hostname port) = - Text.decodeUtf8With Text.lenientDecode hostname - <> ":" - <> Text.pack (show port) + toWai (RemoteError _ _ e) = + federationRemoteHTTP2Error e + toWai (RemoteErrorResponse _ _ status body) = + federationRemoteResponseError status body data Remote m a where DiscoverAndCall :: diff --git a/services/federator/src/Federator/Response.hs b/services/federator/src/Federator/Response.hs index ae248f01e18..04662a1da3a 100644 --- a/services/federator/src/Federator/Response.hs +++ b/services/federator/src/Federator/Response.hs @@ -17,7 +17,6 @@ module Federator.Response ( defaultHeaders, - serve, serveServant, runFederator, runWaiError, @@ -109,20 +108,6 @@ runWaiError = err $ Wai.logErrorMsg e throw e -serve :: - (Wai.Request -> Sem AllEffects Wai.Response) -> - Env -> - Int -> - IO () -serve action env port = - Warp.run port - . Wai.catchErrors (view applog env) [] - $ app - where - app :: Wai.Application - app req respond = - runCodensity (runFederator env (action req)) respond - serveServant :: forall routes. (HasServer (ToServantApi routes) '[], GenericServant routes AsServer, Server (ToServantApi routes) ~ ToServant routes AsServer) => diff --git a/services/federator/src/Federator/Validation.hs b/services/federator/src/Federator/Validation.hs index 5f9fd7cf64a..38c315a6498 100644 --- a/services/federator/src/Federator/Validation.hs +++ b/services/federator/src/Federator/Validation.hs @@ -62,19 +62,19 @@ instance AsWai ValidationError where toWai err = Wai.mkError (validationErrorStatus err) (validationErrorLabel err) . LText.fromStrict - $ waiErrorDescription err - - waiErrorDescription :: ValidationError -> Text - waiErrorDescription NoClientCertificate = "no client certificate provided" - waiErrorDescription (CertificateParseError reason) = - "certificate parse failure: " <> reason - waiErrorDescription (DomainParseError domain) = - "domain parse failure for [" <> domain <> "]" - waiErrorDescription (AuthenticationFailure errs) = - "none of the domain names match the certificate, errors: " - <> Text.pack (show (toList errs)) - waiErrorDescription (FederationDenied domain) = - "origin domain [" <> domainText domain <> "] not in the federation allow list" + $ validationErrorDescription err + +validationErrorDescription :: ValidationError -> Text +validationErrorDescription NoClientCertificate = "no client certificate provided" +validationErrorDescription (CertificateParseError reason) = + "certificate parse failure: " <> reason +validationErrorDescription (DomainParseError domain) = + "domain parse failure for [" <> domain <> "]" +validationErrorDescription (AuthenticationFailure errs) = + "none of the domain names match the certificate, errors: " + <> Text.pack (show (toList errs)) +validationErrorDescription (FederationDenied domain) = + "origin domain [" <> domainText domain <> "] not in the federation allow list" validationErrorLabel :: ValidationError -> LText validationErrorLabel NoClientCertificate = "no-client-certificate" diff --git a/services/galley/test/integration/API/Teams.hs b/services/galley/test/integration/API/Teams.hs index 80a322d18f1..0b95dd4c4d9 100644 --- a/services/galley/test/integration/API/Teams.hs +++ b/services/galley/test/integration/API/Teams.hs @@ -404,7 +404,7 @@ testEnableSSOPerTeam = do let putSSOEnabledInternalCheckNotImplemented :: HasCallStack => TestM () putSSOEnabledInternalCheckNotImplemented = do g <- viewGalley - Wai.Error status label _ _ <- + waierr <- responseJsonUnsafe <$> put ( g @@ -412,8 +412,8 @@ testEnableSSOPerTeam = do . json (Public.WithStatusNoLock Public.FeatureStatusDisabled Public.SSOConfig Public.FeatureTTLUnlimited) ) liftIO $ do - assertEqual "bad status" status403 status - assertEqual "bad label" "not-implemented" label + assertEqual "bad status" status403 (Wai.code waierr) + assertEqual "bad label" "not-implemented" (Wai.label waierr) featureSSO <- view (tsGConf . settings . featureFlags . flagSSO) case featureSSO of FeatureSSOEnabledByDefault -> check "Teams should start with SSO enabled" Public.FeatureStatusEnabled @@ -435,10 +435,10 @@ testEnableTeamSearchVisibilityPerTeam = do let putSearchVisibilityCheckNotAllowed :: TestM () putSearchVisibilityCheckNotAllowed = do g <- viewGalley - Wai.Error status label _ _ <- responseJsonUnsafe <$> putSearchVisibility g owner tid SearchVisibilityNoNameOutsideTeam + waierr <- responseJsonUnsafe <$> putSearchVisibility g owner tid SearchVisibilityNoNameOutsideTeam liftIO $ do - assertEqual "bad status" status403 status - assertEqual "bad label" "team-search-visibility-not-enabled" label + assertEqual "bad status" status403 (Wai.code waierr) + assertEqual "bad label" "team-search-visibility-not-enabled" (Wai.label waierr) let getSearchVisibilityCheck :: TeamSearchVisibility -> TestM () getSearchVisibilityCheck vis = do g <- viewGalley diff --git a/services/spar/src/Spar/Error.hs b/services/spar/src/Spar/Error.hs index 30c59c4a6dd..c273e465c8b 100644 --- a/services/spar/src/Spar/Error.hs +++ b/services/spar/src/Spar/Error.hs @@ -131,10 +131,10 @@ sparToServerError :: SparError -> ServerError sparToServerError = either id waiToServant . renderSparError waiToServant :: Wai.Error -> ServerError -waiToServant waierr@(Wai.Error status label _ _) = +waiToServant waierr = ServerError - { errHTTPCode = statusCode status, - errReasonPhrase = cs label, + { errHTTPCode = statusCode (Wai.code waierr), + errReasonPhrase = cs (Wai.label waierr), errBody = encode waierr, errHeaders = [] } diff --git a/tools/stern/src/Stern/API.hs b/tools/stern/src/Stern/API.hs index 03832056ac0..a310175e9f4 100644 --- a/tools/stern/src/Stern/API.hs +++ b/tools/stern/src/Stern/API.hs @@ -46,7 +46,7 @@ import GHC.TypeLits (KnownSymbol) import Imports hiding (head) import Network.HTTP.Types import Network.Wai -import Network.Wai.Utilities +import Network.Wai.Utilities as Wai import Network.Wai.Utilities.Server qualified as Server import Servant (NoContent (NoContent), ServerT, (:<|>) (..)) import Servant qualified @@ -107,7 +107,7 @@ sitemap env = Servant.Server.hoistServer (Proxy @SternAPI) nt sitemap' fmapL renderError <$> Stern.App.runAppT env (runExceptT m) renderError :: Error -> Servant.Server.ServerError - renderError (Error code label message _) = + renderError (Error code label message _ _) = Servant.Server.ServerError (statusCode code) (cs label) (cs message) [("Content-type", "application/json")] sitemap' :: ServerT SternAPI Handler