From 01a289d03df2c7573386817cb5854d29901d9d69 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Sat, 13 Apr 2024 13:54:52 +0200 Subject: [PATCH 01/10] Remove remaining splinters of wai-routing, wai-predicate from brig. --- changelog.d/5-internal/wpb8691 | 1 + libs/metrics-wai/src/Data/Metrics/Servant.hs | 10 ++-- libs/metrics-wai/src/Data/Metrics/Types.hs | 2 +- services/brig/brig.cabal | 3 -- services/brig/default.nix | 4 -- services/brig/src/Brig/API.hs | 31 ------------ services/brig/src/Brig/API/Handler.hs | 45 ++--------------- services/brig/src/Brig/API/Internal.hs | 47 +++++++----------- services/brig/src/Brig/Provider/API.hs | 52 +++++++++++--------- services/brig/src/Brig/Run.hs | 13 +---- services/brig/test/integration/Run.hs | 13 +---- services/galley/src/Galley/Run.hs | 4 +- 12 files changed, 62 insertions(+), 163 deletions(-) create mode 100644 changelog.d/5-internal/wpb8691 delete mode 100644 services/brig/src/Brig/API.hs diff --git a/changelog.d/5-internal/wpb8691 b/changelog.d/5-internal/wpb8691 new file mode 100644 index 00000000000..de783e455e1 --- /dev/null +++ b/changelog.d/5-internal/wpb8691 @@ -0,0 +1 @@ +Remove remaining splinters of wai-routing, wai-predicate from brig. diff --git a/libs/metrics-wai/src/Data/Metrics/Servant.hs b/libs/metrics-wai/src/Data/Metrics/Servant.hs index 372cdc95055..26467265c66 100644 --- a/libs/metrics-wai/src/Data/Metrics/Servant.hs +++ b/libs/metrics-wai/src/Data/Metrics/Servant.hs @@ -54,8 +54,12 @@ servantPrometheusMiddleware _ = Promth.prometheus conf . instrument promthNormal -- See Note [Raw Response] instrument = Promth.instrumentHandlerValueWithFilter Promth.ignoreRawResponses -servantPlusWAIPrometheusMiddleware :: forall proxy api a m b. (RoutesToPaths api, Monad m) => Routes a m b -> proxy api -> Wai.Middleware -servantPlusWAIPrometheusMiddleware routes _ = do +servantPlusWAIPrometheusMiddleware :: forall proxy api. (RoutesToPaths api) => proxy api -> Wai.Middleware +servantPlusWAIPrometheusMiddleware = servantPlusWAIPrometheusMiddlewareLegacy @proxy @api @_ @Identity Nothing + +-- | Consider using `servantPlusWAIPrometheusMiddleware` instead. +servantPlusWAIPrometheusMiddlewareLegacy :: forall proxy api a m b. (RoutesToPaths api, Monad m) => Maybe (Routes a m b) -> proxy api -> Wai.Middleware +servantPlusWAIPrometheusMiddlewareLegacy mbRoutes _ = do Promth.prometheus conf . instrument (normalizeWaiRequestRoute paths) where -- See Note [Raw Response] @@ -63,7 +67,7 @@ servantPlusWAIPrometheusMiddleware routes _ = do paths = let Paths servantPaths = routesToPaths @api - Paths waiPaths = treeToPaths (prepare routes) + Paths waiPaths = maybe mempty (treeToPaths . prepare) mbRoutes in Paths (meltTree (servantPaths <> waiPaths)) conf :: PrometheusSettings diff --git a/libs/metrics-wai/src/Data/Metrics/Types.hs b/libs/metrics-wai/src/Data/Metrics/Types.hs index 0d1a70903d0..8f92552effd 100644 --- a/libs/metrics-wai/src/Data/Metrics/Types.hs +++ b/libs/metrics-wai/src/Data/Metrics/Types.hs @@ -40,7 +40,7 @@ newtype PathTemplate = PathTemplate Text -- | A 'Forest' of path segments. A path segment is 'Left' if it captures a value -- (e.g. user id). newtype Paths = Paths (Forest PathSegment) - deriving (Eq, Show) + deriving (Eq, Show, Monoid, Semigroup) type PathSegment = Either ByteString ByteString diff --git a/services/brig/brig.cabal b/services/brig/brig.cabal index 4e0c272153d..f24644d2d67 100644 --- a/services/brig/brig.cabal +++ b/services/brig/brig.cabal @@ -77,7 +77,6 @@ library -- cabal-fmt: expand src exposed-modules: Brig.Allowlists - Brig.API Brig.API.Auth Brig.API.Client Brig.API.Connection @@ -358,8 +357,6 @@ library , wai >=3.0 , wai-extra >=3.0 , wai-middleware-gunzip >=0.0.2 - , wai-predicates >=0.8 - , wai-routing >=0.12 , wai-utilities >=0.16 , wire-api , wire-api-federation diff --git a/services/brig/default.nix b/services/brig/default.nix index 6c13f6194ea..37c5d355190 100644 --- a/services/brig/default.nix +++ b/services/brig/default.nix @@ -149,9 +149,7 @@ , wai , wai-extra , wai-middleware-gunzip -, wai-predicates , wai-route -, wai-routing , wai-utilities , warp , warp-tls @@ -284,8 +282,6 @@ mkDerivation { wai wai-extra wai-middleware-gunzip - wai-predicates - wai-routing wai-utilities wire-api wire-api-federation diff --git a/services/brig/src/Brig/API.hs b/services/brig/src/Brig/API.hs deleted file mode 100644 index ba318c3f2b5..00000000000 --- a/services/brig/src/Brig/API.hs +++ /dev/null @@ -1,31 +0,0 @@ --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . - -module Brig.API - ( sitemap, - ) -where - -import Brig.API.Handler (Handler) -import Brig.API.Internal qualified as Internal -import Brig.Effects.GalleyProvider (GalleyProvider) -import Network.Wai.Routing (Routes) -import Polysemy - -sitemap :: forall r. (Member GalleyProvider r) => Routes () (Handler r) () -sitemap = do - Internal.sitemap diff --git a/services/brig/src/Brig/API/Handler.hs b/services/brig/src/Brig/API/Handler.hs index bbea923f517..4c6e92e341a 100644 --- a/services/brig/src/Brig/API/Handler.hs +++ b/services/brig/src/Brig/API/Handler.hs @@ -18,11 +18,9 @@ module Brig.API.Handler ( -- * Handler Monad Handler, - runHandler, toServantHandler, -- * Utilities - JSON, parseJsonBody, checkAllowlist, checkAllowlistWithError, @@ -53,13 +51,9 @@ import Data.Text.Encoding qualified as Text import Data.ZAuth.Validation qualified as ZV import Imports import Network.HTTP.Types (Status (statusCode, statusMessage)) -import Network.Wai (Request, ResponseReceived) -import Network.Wai.Predicate (Media) -import Network.Wai.Routing (Continue) import Network.Wai.Utilities.Error ((!>>)) import Network.Wai.Utilities.Error qualified as WaiError import Network.Wai.Utilities.Request (JsonRequest, parseBody) -import Network.Wai.Utilities.Response (addHeader, json, setStatus) import Network.Wai.Utilities.Server qualified as Server import Servant qualified import System.Logger qualified as Log @@ -72,18 +66,6 @@ import Wire.API.Error.Brig type Handler r = ExceptT Error (AppT r) -runHandler :: - Env -> - Request -> - (Handler BrigCanonicalEffects) ResponseReceived -> - Continue IO -> - IO ResponseReceived -runHandler e r h k = do - a <- - runBrigToIO e (runExceptT h) - `catches` brigErrorHandlers (view applog e) (unRequestId (view requestId e)) - either (onError (view applog e) r k) pure a - toServantHandler :: Env -> (Handler BrigCanonicalEffects) a -> Servant.Handler a toServantHandler env action = do let logger = view applog env @@ -135,33 +117,12 @@ brigErrorHandlers logger reqId = throwIO e ] -onError :: Logger -> Request -> Continue IO -> Error -> IO ResponseReceived -onError g r k e = do - Server.logError g (Just r) we - -- This function exists to workaround a problem that existed in nginx 5 years - -- ago. Context here: - -- https://github.com/zinfra/wai-utilities/commit/3d7e8349d3463e5ee2c3ebe89c717baeef1a8241 - -- So, this can probably be deleted and is not part of the new servant - -- handler. - Server.flushRequestBody r - k - $ setStatus (WaiError.code we) - . appEndo (foldMap (Endo . uncurry addHeader) hs) - $ json e - where - (we, hs) = case e of - StdError x -> (x, []) - RichError x _ h -> (x, h) - ------------------------------------------------------------------------------- -- Utilities --- TODO: move to libs/wai-utilities? -type JSON = Media "application" "json" - --- TODO: move to libs/wai-utilities? there is a parseJson' in "Network.Wai.Utilities.Request", --- but adjusting its signature to this here would require to move more code out of brig (at least --- badRequest and probably all the other errors). +-- This could go to libs/wai-utilities. There is a `parseJson'` in +-- "Network.Wai.Utilities.Request", but adding `parseJsonBody` there would require to move +-- more code out of brig. parseJsonBody :: (FromJSON a, MonadIO m) => JsonRequest a -> ExceptT Error m a parseJsonBody req = parseBody req !>> StdError . badRequest diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index 75c4d6a3976..d2f95f55c8c 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -15,9 +15,8 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . module Brig.API.Internal - ( sitemap, - servantSitemap, - BrigIRoutes.API, + ( servantSitemap, + API, getMLSClients, ) where @@ -74,7 +73,6 @@ import Data.Set qualified as Set import Data.Time.Clock (UTCTime) import Data.Time.Clock.System import Imports hiding (head) -import Network.Wai.Routing hiding (toList) import Network.Wai.Utilities as Utilities import Polysemy import Polysemy.Input (Input) @@ -104,8 +102,7 @@ import Wire.Rpc import Wire.Sem.Concurrency import Wire.Sem.Paging.Cassandra (InternalPaging) ---------------------------------------------------------------------------- --- Sitemap (servant) +type API = BrigIRoutes.API :<|> Provider.InternalProviderAPI servantSitemap :: forall r p. @@ -125,20 +122,22 @@ servantSitemap :: Member TinyLog r, Member (UserPendingActivationStore p) r ) => - ServerT BrigIRoutes.API (Handler r) + ServerT API (Handler r) servantSitemap = - istatusAPI - :<|> ejpdAPI - :<|> accountAPI - :<|> mlsAPI - :<|> getVerificationCode - :<|> teamsAPI - :<|> userAPI - :<|> clientAPI - :<|> authAPI - :<|> internalOauthAPI - :<|> internalSearchIndexAPI - :<|> federationRemotesAPI + ( istatusAPI + :<|> ejpdAPI + :<|> accountAPI + :<|> mlsAPI + :<|> getVerificationCode + :<|> teamsAPI + :<|> userAPI + :<|> clientAPI + :<|> authAPI + :<|> internalOauthAPI + :<|> internalSearchIndexAPI + :<|> federationRemotesAPI + ) + :<|> Provider.internalProviderAPI istatusAPI :: forall r. ServerT BrigIRoutes.IStatusAPI (Handler r) istatusAPI = Named @"get-status" (pure NoContent) @@ -373,16 +372,6 @@ internalSearchIndexAPI = :<|> Named @"indexReindex" (NoContent <$ lift (wrapClient Search.reindexAll)) :<|> Named @"indexReindexIfSameOrNewer" (NoContent <$ lift (wrapClient Search.reindexAllIfSameOrNewer)) ---------------------------------------------------------------------------- --- Sitemap (wai-route) - -sitemap :: - ( Member GalleyProvider r - ) => - Routes a (Handler r) () -sitemap = unsafeCallsFed @'Brig @"on-user-deleted-connections" $ do - Provider.routesInternal - --------------------------------------------------------------------------- -- Handlers diff --git a/services/brig/src/Brig/Provider/API.hs b/services/brig/src/Brig/Provider/API.hs index 535ad5c9750..55acf667cd1 100644 --- a/services/brig/src/Brig/Provider/API.hs +++ b/services/brig/src/Brig/Provider/API.hs @@ -17,10 +17,11 @@ module Brig.Provider.API ( -- * Main stuff - routesInternal, botAPI, servicesAPI, providerAPI, + InternalProviderAPI, + internalProviderAPI, -- * Event handlers finishDeleteService, @@ -79,21 +80,16 @@ import Data.Text.Encoding qualified as Text import Data.Text.Lazy qualified as Text import GHC.TypeNats import Imports -import Network.HTTP.Types.Status -import Network.Wai (Response) -import Network.Wai.Predicate (accept) -import Network.Wai.Routing +import Network.HTTP.Types import Network.Wai.Utilities.Error ((!>>)) import Network.Wai.Utilities.Error qualified as Wai -import Network.Wai.Utilities.Response (json) -import Network.Wai.Utilities.ZAuth import OpenSSL.EVP.Digest qualified as SSL import OpenSSL.EVP.PKey qualified as SSL import OpenSSL.PEM qualified as SSL import OpenSSL.RSA qualified as SSL import OpenSSL.Random (randBytes) import Polysemy -import Servant (ServerT, (:<|>) (..)) +import Servant (JSON, QueryParam', Required, ServerT, Strict, Summary, (:<|>) (..), (:>)) import Ssl.Util qualified as SSL import System.Logger.Class (MonadLogger) import UnliftIO.Async (pooledMapConcurrentlyN_) @@ -114,6 +110,7 @@ import Wire.API.Provider.External qualified as Ext import Wire.API.Provider.Service import Wire.API.Provider.Service qualified as Public import Wire.API.Provider.Service.Tag qualified as Public +import Wire.API.Routes.MultiVerb import Wire.API.Routes.Named (Named (Named)) import Wire.API.Routes.Public.Brig.Bot (BotAPI) import Wire.API.Routes.Public.Brig.Provider (ProviderAPI) @@ -177,11 +174,23 @@ providerAPI = :<|> Named @"provider-get-account" getAccount :<|> Named @"provider-get-profile" getProviderProfile -routesInternal :: Member GalleyProvider r => Routes a (Handler r) () -routesInternal = do - get "/i/provider/activation-code" (continue getActivationCodeH) $ - accept "application" "json" - .&> param "email" +type InternalProviderAPI = + -- (This was introduced here to get rid of wai-routing and wai-predicate. It would normally + -- go into wire-api, but it depends on "Brig.Code", and the required module restructuring + -- can wait, other stuff to do.) + "i" + :> ( Named + "provider-internal-get-activation-code" + ( Summary "Retrieve activation code via api instead of email (for testing only)" + :> "provider" + :> "activation-code" + :> QueryParam' '[Required, Strict] "email" Public.Email + :> MultiVerb1 'GET '[JSON] (Respond 200 "" FoundActivationCode) + ) + ) + +internalProviderAPI :: Member GalleyProvider r => ServerT InternalProviderAPI (Handler r) +internalProviderAPI = Named @"provider-internal-get-activation-code" getActivationCodeH -------------------------------------------------------------------------------- -- Public API (Unauthenticated) @@ -242,26 +251,21 @@ activateAccountKey key val = do lift $ sendApprovalConfirmMail name email pure . Just $ Public.ProviderActivationResponse email -getActivationCodeH :: Member GalleyProvider r => Public.Email -> (Handler r) Response +getActivationCodeH :: Member GalleyProvider r => Public.Email -> (Handler r) FoundActivationCode getActivationCodeH e = do guardSecondFactorDisabled Nothing - json <$> getActivationCode e - -getActivationCode :: Public.Email -> (Handler r) FoundActivationCode -getActivationCode e = do email <- case validateEmail e of Right em -> pure em Left _ -> throwStd (errorToWai @'E.InvalidEmail) gen <- Code.mkGen (Code.ForEmail email) code <- wrapClientE $ Code.lookup (Code.genKey gen) Code.IdentityVerification - maybe (throwStd activationKeyNotFound) (pure . FoundActivationCode) code + maybe (throwStd activationKeyNotFound) (pure . mkFoundActivationCode) code -newtype FoundActivationCode = FoundActivationCode Code.Code +newtype FoundActivationCode = FoundActivationCode Code.KeyValuePair + deriving newtype (ToJSON, FromJSON) -instance ToJSON FoundActivationCode where - toJSON (FoundActivationCode vcode) = - toJSON $ - Code.KeyValuePair (Code.codeKey vcode) (Code.codeValue vcode) +mkFoundActivationCode :: Code.Code -> FoundActivationCode +mkFoundActivationCode vcode = FoundActivationCode $ Code.KeyValuePair (Code.codeKey vcode) (Code.codeValue vcode) login :: Member GalleyProvider r => ProviderLogin -> Handler r ProviderTokenCookie login l = do diff --git a/services/brig/src/Brig/Run.hs b/services/brig/src/Brig/Run.hs index b74e58081c2..19aebdeb3a7 100644 --- a/services/brig/src/Brig/Run.hs +++ b/services/brig/src/Brig/Run.hs @@ -22,7 +22,6 @@ module Brig.Run where import AWS.Util (readAuthExpiration) -import Brig.API (sitemap) import Brig.API.Federation import Brig.API.Handler import Brig.API.Internal qualified as IAPI @@ -59,8 +58,6 @@ import Network.HTTP.Types qualified as HTTP import Network.Wai qualified as Wai import Network.Wai.Middleware.Gunzip qualified as GZip import Network.Wai.Middleware.Gzip qualified as GZip -import Network.Wai.Routing (Tree) -import Network.Wai.Routing.Route (App) import Network.Wai.Utilities (lookupRequestId) import Network.Wai.Utilities.Server import Network.Wai.Utilities.Server qualified as Server @@ -119,22 +116,16 @@ mkApp o = do e <- newEnv o pure (middleware e $ \reqId -> servantApp (e & requestId .~ reqId), e) where - rtree :: Tree (App (Handler BrigCanonicalEffects)) - rtree = compile sitemap - middleware :: Env -> (RequestId -> Wai.Application) -> Wai.Application middleware e = -- this rewrites the request, so it must be at the top (i.e. applied last) versionMiddleware (e ^. disabledVersions) - . Metrics.servantPlusWAIPrometheusMiddleware (sitemap @BrigCanonicalEffects) (Proxy @ServantCombinedAPI) + . Metrics.servantPlusWAIPrometheusMiddleware (Proxy @ServantCombinedAPI) . GZip.gunzip . GZip.gzip GZip.def . catchErrors (e ^. applog) [Right $ e ^. metrics] . lookupRequestIdMiddleware (e ^. applog) - app :: Env -> Wai.Request -> (Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived - app e r k = runHandler e r (Server.route rtree r k) k - -- the servant API wraps the one defined using wai-routing servantApp :: Env -> Wai.Application servantApp e = @@ -147,7 +138,6 @@ mkApp o = do :<|> hoistServerWithDomain @IAPI.API (toServantHandler e) IAPI.servantSitemap :<|> hoistServerWithDomain @FederationAPI (toServantHandler e) federationSitemap :<|> hoistServerWithDomain @VersionAPI (toServantHandler e) versionAPI - :<|> Servant.Tagged (app e) ) type ServantCombinedAPI = @@ -156,7 +146,6 @@ type ServantCombinedAPI = :<|> IAPI.API :<|> FederationAPI :<|> VersionAPI - :<|> Servant.Raw ) lookupRequestIdMiddleware :: Logger -> (RequestId -> Wai.Application) -> Wai.Application diff --git a/services/brig/test/integration/Run.hs b/services/brig/test/integration/Run.hs index 190a2553d80..ebd91122302 100644 --- a/services/brig/test/integration/Run.hs +++ b/services/brig/test/integration/Run.hs @@ -35,16 +35,12 @@ import API.User qualified as User import API.UserPendingActivation qualified as UserPendingActivation import Bilge hiding (header, host, port) import Bilge qualified -import Brig.API (sitemap) import Brig.AWS qualified as AWS -import Brig.CanonicalInterpreter import Brig.Options qualified as Opts import Cassandra.Util (defInitCassandra) import Control.Lens import Data.Aeson import Data.ByteString.Char8 qualified as B8 -import Data.Metrics.Test (pathsConsistencyCheck) -import Data.Metrics.WaiRoute (treeToPaths) import Data.Text.Encoding (encodeUtf8) import Data.Yaml (decodeFileEither) import Federation.End2end qualified @@ -53,14 +49,12 @@ import Index.Create qualified import Network.HTTP.Client qualified as HTTP import Network.HTTP.Client.TLS (tlsManagerSettings) import Network.URI (pathSegments) -import Network.Wai.Utilities.Server (compile) import OpenSSL (withOpenSSL) import Options.Applicative hiding (action) import SMTP qualified import System.Environment (withArgs) import System.Logger qualified as Logger import Test.Tasty -import Test.Tasty.HUnit import Test.Tasty.Ingredients import Test.Tasty.Runners import Test.Tasty.Runners.AntXML @@ -159,12 +153,7 @@ runTests iConf brigOpts otherArgs = do withArgs otherArgs . defaultMainWithIngredients (listingTests : (composeReporters antXMLRunner consoleTestReporter) : defaultIngredients) $ testGroup "Brig API Integration" - $ [ testCase "sitemap" $ - assertEqual - "inconcistent sitemap" - mempty - (pathsConsistencyCheck . treeToPaths . compile $ Brig.API.sitemap @BrigCanonicalEffects), - userApi, + $ [ userApi, providerApi, searchApis, teamApis, diff --git a/services/galley/src/Galley/Run.hs b/services/galley/src/Galley/Run.hs index 592ad9f3ed8..ecac7fe614f 100644 --- a/services/galley/src/Galley/Run.hs +++ b/services/galley/src/Galley/Run.hs @@ -36,7 +36,7 @@ import Data.Id import Data.Metrics (Metrics) import Data.Metrics.AWS (gaugeTokenRemaing) import Data.Metrics.Middleware qualified as M -import Data.Metrics.Servant (servantPlusWAIPrometheusMiddleware) +import Data.Metrics.Servant (servantPlusWAIPrometheusMiddlewareLegacy) import Data.Misc (portNumber) import Data.Singletons import Data.Text (unpack) @@ -97,7 +97,7 @@ mkApp opts = lift $ runClient (env ^. cstate) $ versionCheck schemaVersion let middlewares = versionMiddleware (foldMap expandVersionExp (opts ^. settings . disabledAPIVersions)) - . servantPlusWAIPrometheusMiddleware API.waiSitemap (Proxy @CombinedAPI) + . servantPlusWAIPrometheusMiddlewareLegacy (Just API.waiSitemap) (Proxy @CombinedAPI) . GZip.gunzip . GZip.gzip GZip.def . catchErrors logger [Right metrics] From eca78b43c7ee66285ea70089f94c627079ecee55 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Sat, 13 Apr 2024 15:00:49 +0200 Subject: [PATCH 02/10] hlint. --- libs/metrics-wai/src/Data/Metrics/Servant.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libs/metrics-wai/src/Data/Metrics/Servant.hs b/libs/metrics-wai/src/Data/Metrics/Servant.hs index 26467265c66..55067cc2528 100644 --- a/libs/metrics-wai/src/Data/Metrics/Servant.hs +++ b/libs/metrics-wai/src/Data/Metrics/Servant.hs @@ -67,7 +67,7 @@ servantPlusWAIPrometheusMiddlewareLegacy mbRoutes _ = do paths = let Paths servantPaths = routesToPaths @api - Paths waiPaths = maybe mempty (treeToPaths . prepare) mbRoutes + Paths waiPaths = foldMap (treeToPaths . prepare) mbRoutes in Paths (meltTree (servantPaths <> waiPaths)) conf :: PrometheusSettings From 6567193c81a83dd417165c7e263ba19fd019308d Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Mon, 15 Apr 2024 10:27:12 +0200 Subject: [PATCH 03/10] remove silly detour. --- libs/metrics-wai/src/Data/Metrics/Servant.hs | 9 +++------ services/brig/src/Brig/Run.hs | 2 +- services/galley/src/Galley/Run.hs | 4 ++-- 3 files changed, 6 insertions(+), 9 deletions(-) diff --git a/libs/metrics-wai/src/Data/Metrics/Servant.hs b/libs/metrics-wai/src/Data/Metrics/Servant.hs index 55067cc2528..fa31b0a1ad6 100644 --- a/libs/metrics-wai/src/Data/Metrics/Servant.hs +++ b/libs/metrics-wai/src/Data/Metrics/Servant.hs @@ -54,12 +54,9 @@ servantPrometheusMiddleware _ = Promth.prometheus conf . instrument promthNormal -- See Note [Raw Response] instrument = Promth.instrumentHandlerValueWithFilter Promth.ignoreRawResponses -servantPlusWAIPrometheusMiddleware :: forall proxy api. (RoutesToPaths api) => proxy api -> Wai.Middleware -servantPlusWAIPrometheusMiddleware = servantPlusWAIPrometheusMiddlewareLegacy @proxy @api @_ @Identity Nothing - -- | Consider using `servantPlusWAIPrometheusMiddleware` instead. -servantPlusWAIPrometheusMiddlewareLegacy :: forall proxy api a m b. (RoutesToPaths api, Monad m) => Maybe (Routes a m b) -> proxy api -> Wai.Middleware -servantPlusWAIPrometheusMiddlewareLegacy mbRoutes _ = do +servantPlusWAIPrometheusMiddleware :: forall proxy api a m b. (RoutesToPaths api, Monad m) => Routes a m b -> proxy api -> Wai.Middleware +servantPlusWAIPrometheusMiddleware routes _ = do Promth.prometheus conf . instrument (normalizeWaiRequestRoute paths) where -- See Note [Raw Response] @@ -67,7 +64,7 @@ servantPlusWAIPrometheusMiddlewareLegacy mbRoutes _ = do paths = let Paths servantPaths = routesToPaths @api - Paths waiPaths = foldMap (treeToPaths . prepare) mbRoutes + Paths waiPaths = treeToPaths (prepare routes) in Paths (meltTree (servantPaths <> waiPaths)) conf :: PrometheusSettings diff --git a/services/brig/src/Brig/Run.hs b/services/brig/src/Brig/Run.hs index 19aebdeb3a7..65f288f6c2c 100644 --- a/services/brig/src/Brig/Run.hs +++ b/services/brig/src/Brig/Run.hs @@ -120,7 +120,7 @@ mkApp o = do middleware e = -- this rewrites the request, so it must be at the top (i.e. applied last) versionMiddleware (e ^. disabledVersions) - . Metrics.servantPlusWAIPrometheusMiddleware (Proxy @ServantCombinedAPI) + . Metrics.servantPrometheusMiddleware (Proxy @ServantCombinedAPI) . GZip.gunzip . GZip.gzip GZip.def . catchErrors (e ^. applog) [Right $ e ^. metrics] diff --git a/services/galley/src/Galley/Run.hs b/services/galley/src/Galley/Run.hs index ecac7fe614f..592ad9f3ed8 100644 --- a/services/galley/src/Galley/Run.hs +++ b/services/galley/src/Galley/Run.hs @@ -36,7 +36,7 @@ import Data.Id import Data.Metrics (Metrics) import Data.Metrics.AWS (gaugeTokenRemaing) import Data.Metrics.Middleware qualified as M -import Data.Metrics.Servant (servantPlusWAIPrometheusMiddlewareLegacy) +import Data.Metrics.Servant (servantPlusWAIPrometheusMiddleware) import Data.Misc (portNumber) import Data.Singletons import Data.Text (unpack) @@ -97,7 +97,7 @@ mkApp opts = lift $ runClient (env ^. cstate) $ versionCheck schemaVersion let middlewares = versionMiddleware (foldMap expandVersionExp (opts ^. settings . disabledAPIVersions)) - . servantPlusWAIPrometheusMiddlewareLegacy (Just API.waiSitemap) (Proxy @CombinedAPI) + . servantPlusWAIPrometheusMiddleware API.waiSitemap (Proxy @CombinedAPI) . GZip.gunzip . GZip.gzip GZip.def . catchErrors logger [Right metrics] From 02dcf9ce02dd1a746a80a79a3e244a022cbfd26f Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Mon, 15 Apr 2024 10:40:30 +0200 Subject: [PATCH 04/10] Remove unnecessary underscore in var name --- services/brig/test/integration/API/Provider.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/services/brig/test/integration/API/Provider.hs b/services/brig/test/integration/API/Provider.hs index a2479df44e8..538453d1aed 100644 --- a/services/brig/test/integration/API/Provider.hs +++ b/services/brig/test/integration/API/Provider.hs @@ -1680,10 +1680,10 @@ testRegisterProvider db' brig = do activateProvider brig (Code.codeKey vcode) (Code.codeValue vcode) !!! const 200 === statusCode Nothing -> do - _rs <- + rs <- getProviderActivationCodeInternal brig email Date: Mon, 15 Apr 2024 10:42:27 +0200 Subject: [PATCH 05/10] Move provider internal api to wire-api This gets it into swagger. Also get rid of unnecessary newtype wrapper --- libs/types-common/src/Data/Code.hs | 12 ++++--- .../src/Wire/API/Routes/Internal/Brig.hs | 13 ++++++++ services/brig/src/Brig/API/Internal.hs | 30 ++++++++---------- services/brig/src/Brig/Code.hs | 4 +++ services/brig/src/Brig/Provider/API.hs | 31 ++++--------------- services/brig/src/Brig/Run.hs | 1 + 6 files changed, 45 insertions(+), 46 deletions(-) diff --git a/libs/types-common/src/Data/Code.hs b/libs/types-common/src/Data/Code.hs index ba176629701..a26e81abdcc 100644 --- a/libs/types-common/src/Data/Code.hs +++ b/libs/types-common/src/Data/Code.hs @@ -27,10 +27,8 @@ module Data.Code where import Cassandra hiding (Value) import Data.Aeson qualified as A -import Data.Aeson.TH import Data.Bifunctor (Bifunctor (first)) import Data.ByteString.Conversion -import Data.Json.Util import Data.OpenApi qualified as S import Data.OpenApi.ParamSchema import Data.Proxy (Proxy (Proxy)) @@ -123,5 +121,11 @@ data KeyValuePair = KeyValuePair code :: !Value } deriving (Eq, Generic, Show) - -deriveJSON toJSONFieldName ''KeyValuePair + deriving (A.ToJSON, A.FromJSON, S.ToSchema) via Schema KeyValuePair + +instance ToSchema KeyValuePair where + schema = + object "KeyValuePair" $ + KeyValuePair + <$> key .= field "key" schema + <*> code .= field "code" schema diff --git a/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs b/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs index 42af0b8ca40..43ca007abb1 100644 --- a/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs +++ b/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs @@ -30,6 +30,7 @@ module Wire.API.Routes.Internal.Brig FederationRemotesAPI, EJPDRequest, ISearchIndexAPI, + ProviderAPI, GetAccountConferenceCallingConfig, PutAccountConferenceCallingConfig, DeleteAccountConferenceCallingConfig, @@ -538,6 +539,7 @@ type API = :<|> OAuthAPI :<|> ISearchIndexAPI :<|> FederationRemotesAPI + :<|> ProviderAPI ) type IStatusAPI = @@ -766,6 +768,17 @@ type FederationRemotesAPI = :> Delete '[JSON] () ) +type ProviderAPI = + ( Named + "get-provider-activation-code" + ( Summary "Retrieve activation code via api instead of email (for testing only)" + :> "provider" + :> "activation-code" + :> QueryParam' '[Required, Strict] "email" Email + :> MultiVerb1 'GET '[JSON] (Respond 200 "" Code.KeyValuePair) + ) + ) + type FederationRemotesAPIDescription = "See https://docs.wire.com/understand/federation/backend-communication.html#configuring-remote-connections for background. " diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index d2f95f55c8c..28d004f2ec8 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -16,7 +16,6 @@ -- with this program. If not, see . module Brig.API.Internal ( servantSitemap, - API, getMLSClients, ) where @@ -102,8 +101,6 @@ import Wire.Rpc import Wire.Sem.Concurrency import Wire.Sem.Paging.Cassandra (InternalPaging) -type API = BrigIRoutes.API :<|> Provider.InternalProviderAPI - servantSitemap :: forall r p. ( Member BlacklistPhonePrefixStore r, @@ -122,21 +119,20 @@ servantSitemap :: Member TinyLog r, Member (UserPendingActivationStore p) r ) => - ServerT API (Handler r) + ServerT BrigIRoutes.API (Handler r) servantSitemap = - ( istatusAPI - :<|> ejpdAPI - :<|> accountAPI - :<|> mlsAPI - :<|> getVerificationCode - :<|> teamsAPI - :<|> userAPI - :<|> clientAPI - :<|> authAPI - :<|> internalOauthAPI - :<|> internalSearchIndexAPI - :<|> federationRemotesAPI - ) + istatusAPI + :<|> ejpdAPI + :<|> accountAPI + :<|> mlsAPI + :<|> getVerificationCode + :<|> teamsAPI + :<|> userAPI + :<|> clientAPI + :<|> authAPI + :<|> internalOauthAPI + :<|> internalSearchIndexAPI + :<|> federationRemotesAPI :<|> Provider.internalProviderAPI istatusAPI :: forall r. ServerT BrigIRoutes.IStatusAPI (Handler r) diff --git a/services/brig/src/Brig/Code.hs b/services/brig/src/Brig/Code.hs index 2d0fc50485c..7840b8e3cb5 100644 --- a/services/brig/src/Brig/Code.hs +++ b/services/brig/src/Brig/Code.hs @@ -40,6 +40,7 @@ module Brig.Code codeForPhone, codeKey, codeValue, + codeToKeyValuePair, codeTTL, codeAccount, scopeFromAction, @@ -114,6 +115,9 @@ scopeFromAction = \case User.Login -> AccountLogin User.DeleteTeam -> DeleteTeam +codeToKeyValuePair :: Code -> KeyValuePair +codeToKeyValuePair code = KeyValuePair code.codeKey code.codeValue + -- | The same 'Key' can exist with different 'Value's in different -- 'Scope's at the same time. data Scope diff --git a/services/brig/src/Brig/Provider/API.hs b/services/brig/src/Brig/Provider/API.hs index 55acf667cd1..6bf5676647f 100644 --- a/services/brig/src/Brig/Provider/API.hs +++ b/services/brig/src/Brig/Provider/API.hs @@ -20,7 +20,6 @@ module Brig.Provider.API botAPI, servicesAPI, providerAPI, - InternalProviderAPI, internalProviderAPI, -- * Event handlers @@ -89,7 +88,7 @@ import OpenSSL.PEM qualified as SSL import OpenSSL.RSA qualified as SSL import OpenSSL.Random (randBytes) import Polysemy -import Servant (JSON, QueryParam', Required, ServerT, Strict, Summary, (:<|>) (..), (:>)) +import Servant (ServerT, (:<|>) (..)) import Ssl.Util qualified as SSL import System.Logger.Class (MonadLogger) import UnliftIO.Async (pooledMapConcurrentlyN_) @@ -110,7 +109,7 @@ import Wire.API.Provider.External qualified as Ext import Wire.API.Provider.Service import Wire.API.Provider.Service qualified as Public import Wire.API.Provider.Service.Tag qualified as Public -import Wire.API.Routes.MultiVerb +import Wire.API.Routes.Internal.Brig qualified as BrigIRoutes import Wire.API.Routes.Named (Named (Named)) import Wire.API.Routes.Public.Brig.Bot (BotAPI) import Wire.API.Routes.Public.Brig.Provider (ProviderAPI) @@ -174,23 +173,8 @@ providerAPI = :<|> Named @"provider-get-account" getAccount :<|> Named @"provider-get-profile" getProviderProfile -type InternalProviderAPI = - -- (This was introduced here to get rid of wai-routing and wai-predicate. It would normally - -- go into wire-api, but it depends on "Brig.Code", and the required module restructuring - -- can wait, other stuff to do.) - "i" - :> ( Named - "provider-internal-get-activation-code" - ( Summary "Retrieve activation code via api instead of email (for testing only)" - :> "provider" - :> "activation-code" - :> QueryParam' '[Required, Strict] "email" Public.Email - :> MultiVerb1 'GET '[JSON] (Respond 200 "" FoundActivationCode) - ) - ) - -internalProviderAPI :: Member GalleyProvider r => ServerT InternalProviderAPI (Handler r) -internalProviderAPI = Named @"provider-internal-get-activation-code" getActivationCodeH +internalProviderAPI :: Member GalleyProvider r => ServerT BrigIRoutes.ProviderAPI (Handler r) +internalProviderAPI = Named @"get-provider-activation-code" getActivationCodeH -------------------------------------------------------------------------------- -- Public API (Unauthenticated) @@ -251,7 +235,7 @@ activateAccountKey key val = do lift $ sendApprovalConfirmMail name email pure . Just $ Public.ProviderActivationResponse email -getActivationCodeH :: Member GalleyProvider r => Public.Email -> (Handler r) FoundActivationCode +getActivationCodeH :: Member GalleyProvider r => Public.Email -> (Handler r) Code.KeyValuePair getActivationCodeH e = do guardSecondFactorDisabled Nothing email <- case validateEmail e of @@ -259,14 +243,11 @@ getActivationCodeH e = do Left _ -> throwStd (errorToWai @'E.InvalidEmail) gen <- Code.mkGen (Code.ForEmail email) code <- wrapClientE $ Code.lookup (Code.genKey gen) Code.IdentityVerification - maybe (throwStd activationKeyNotFound) (pure . mkFoundActivationCode) code + maybe (throwStd activationKeyNotFound) (pure . Code.codeToKeyValuePair) code newtype FoundActivationCode = FoundActivationCode Code.KeyValuePair deriving newtype (ToJSON, FromJSON) -mkFoundActivationCode :: Code.Code -> FoundActivationCode -mkFoundActivationCode vcode = FoundActivationCode $ Code.KeyValuePair (Code.codeKey vcode) (Code.codeValue vcode) - login :: Member GalleyProvider r => ProviderLogin -> Handler r ProviderTokenCookie login l = do guardSecondFactorDisabled Nothing diff --git a/services/brig/src/Brig/Run.hs b/services/brig/src/Brig/Run.hs index 65f288f6c2c..90316762356 100644 --- a/services/brig/src/Brig/Run.hs +++ b/services/brig/src/Brig/Run.hs @@ -69,6 +69,7 @@ import System.Logger qualified as Log import System.Logger.Class (MonadLogger, err) import Util.Options import Wire.API.Routes.API +import Wire.API.Routes.Internal.Brig qualified as IAPI import Wire.API.Routes.Public.Brig import Wire.API.Routes.Version import Wire.API.Routes.Version.Wai From 2f986a4bc46a372da6ee3062325e91a4fc547b8b Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Mon, 15 Apr 2024 10:43:38 +0200 Subject: [PATCH 06/10] Remove leftover comment --- libs/metrics-wai/src/Data/Metrics/Servant.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/libs/metrics-wai/src/Data/Metrics/Servant.hs b/libs/metrics-wai/src/Data/Metrics/Servant.hs index fa31b0a1ad6..372cdc95055 100644 --- a/libs/metrics-wai/src/Data/Metrics/Servant.hs +++ b/libs/metrics-wai/src/Data/Metrics/Servant.hs @@ -54,7 +54,6 @@ servantPrometheusMiddleware _ = Promth.prometheus conf . instrument promthNormal -- See Note [Raw Response] instrument = Promth.instrumentHandlerValueWithFilter Promth.ignoreRawResponses --- | Consider using `servantPlusWAIPrometheusMiddleware` instead. servantPlusWAIPrometheusMiddleware :: forall proxy api a m b. (RoutesToPaths api, Monad m) => Routes a m b -> proxy api -> Wai.Middleware servantPlusWAIPrometheusMiddleware routes _ = do Promth.prometheus conf . instrument (normalizeWaiRequestRoute paths) From 6cf44a07ad6e61195f30c8b185868c79ec531b9b Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Mon, 15 Apr 2024 10:46:34 +0200 Subject: [PATCH 07/10] Remove unnecessary instances --- libs/metrics-wai/src/Data/Metrics/Types.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libs/metrics-wai/src/Data/Metrics/Types.hs b/libs/metrics-wai/src/Data/Metrics/Types.hs index 8f92552effd..0d1a70903d0 100644 --- a/libs/metrics-wai/src/Data/Metrics/Types.hs +++ b/libs/metrics-wai/src/Data/Metrics/Types.hs @@ -40,7 +40,7 @@ newtype PathTemplate = PathTemplate Text -- | A 'Forest' of path segments. A path segment is 'Left' if it captures a value -- (e.g. user id). newtype Paths = Paths (Forest PathSegment) - deriving (Eq, Show, Monoid, Semigroup) + deriving (Eq, Show) type PathSegment = Either ByteString ByteString From 250b193e36929429a7a233b4b3fa16ae91ffdf36 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Mon, 15 Apr 2024 10:52:13 +0200 Subject: [PATCH 08/10] Remove unnecessary newtype --- services/brig/src/Brig/Provider/API.hs | 4 ---- 1 file changed, 4 deletions(-) diff --git a/services/brig/src/Brig/Provider/API.hs b/services/brig/src/Brig/Provider/API.hs index 6bf5676647f..c59e561e4cb 100644 --- a/services/brig/src/Brig/Provider/API.hs +++ b/services/brig/src/Brig/Provider/API.hs @@ -58,7 +58,6 @@ import Control.Exception.Enclosed (handleAny) import Control.Lens (view, (^.)) import Control.Monad.Catch (MonadMask) import Control.Monad.Except -import Data.Aeson hiding (json) import Data.ByteString.Conversion import Data.ByteString.Lazy.Char8 qualified as LC8 import Data.CommaSeparatedList (CommaSeparatedList (fromCommaSeparatedList)) @@ -245,9 +244,6 @@ getActivationCodeH e = do code <- wrapClientE $ Code.lookup (Code.genKey gen) Code.IdentityVerification maybe (throwStd activationKeyNotFound) (pure . Code.codeToKeyValuePair) code -newtype FoundActivationCode = FoundActivationCode Code.KeyValuePair - deriving newtype (ToJSON, FromJSON) - login :: Member GalleyProvider r => ProviderLogin -> Handler r ProviderTokenCookie login l = do guardSecondFactorDisabled Nothing From ca09f4ecd707cff487dbe6d7693c31d64459c521 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Mon, 15 Apr 2024 11:17:36 +0200 Subject: [PATCH 09/10] hlint --- libs/types-common/src/Data/Code.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/libs/types-common/src/Data/Code.hs b/libs/types-common/src/Data/Code.hs index a26e81abdcc..c745b752caa 100644 --- a/libs/types-common/src/Data/Code.hs +++ b/libs/types-common/src/Data/Code.hs @@ -3,7 +3,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -- This file is part of the Wire Server implementation. -- From c0679f088038eec877def1fff71d395c2de3ac16 Mon Sep 17 00:00:00 2001 From: Magnus Viernickel Date: Tue, 16 Apr 2024 10:04:40 +0200 Subject: [PATCH 10/10] [fix] remove the body check after removing the body in the routes --- services/federator/default.nix | 1 - services/federator/federator.cabal | 1 - .../test/integration/Test/Federator/InwardSpec.hs | 10 ++++------ 3 files changed, 4 insertions(+), 8 deletions(-) diff --git a/services/federator/default.nix b/services/federator/default.nix index af4aa3d502b..5cb5b5b2830 100644 --- a/services/federator/default.nix +++ b/services/federator/default.nix @@ -158,7 +158,6 @@ mkDerivation { text types-common uuid - wai-utilities wire-api wire-api-federation yaml diff --git a/services/federator/federator.cabal b/services/federator/federator.cabal index dec1a6d01e1..0a0767edeb2 100644 --- a/services/federator/federator.cabal +++ b/services/federator/federator.cabal @@ -307,7 +307,6 @@ executable federator-integration , text , types-common , uuid - , wai-utilities , wire-api , wire-api-federation , yaml diff --git a/services/federator/test/integration/Test/Federator/InwardSpec.hs b/services/federator/test/integration/Test/Federator/InwardSpec.hs index b75beeb5a0e..33cd7e89c92 100644 --- a/services/federator/test/integration/Test/Federator/InwardSpec.hs +++ b/services/federator/test/integration/Test/Federator/InwardSpec.hs @@ -33,7 +33,6 @@ import Data.Text.Encoding import Federator.Options hiding (federatorExternal) import Imports import Network.HTTP.Types qualified as HTTP -import Network.Wai.Utilities.Error qualified as E import Test.Federator.Util import Test.Hspec import Test.QuickCheck (arbitrary, generate) @@ -99,11 +98,10 @@ spec env = it "should return 404 'no-endpoint' response from Brig" $ runTestFederator env $ do - err <- - responseJsonError - =<< inwardCall "/federation/brig/this-endpoint-does-not-exist" (encode Aeson.emptyObject) -