diff --git a/changelog.d/5-internal/galley-no-sessiont b/changelog.d/5-internal/galley-no-sessiont new file mode 100644 index 00000000000..82bff1eafe3 --- /dev/null +++ b/changelog.d/5-internal/galley-no-sessiont @@ -0,0 +1 @@ +galley: refactor withSettingsOverrides diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index 07dd05a2cd0..f9c9339e907 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -210,6 +210,7 @@ library , http-types >=0.8 , imports , insert-ordered-containers + , kan-extensions , lens >=4.4 , memory , metrics-wai >=0.4 @@ -437,6 +438,7 @@ executable galley-integration , http-media , http-types , imports + , kan-extensions , lens , lens-aeson , metrics-wai diff --git a/services/galley/package.yaml b/services/galley/package.yaml index 003df7f8835..7a8b3f658d5 100644 --- a/services/galley/package.yaml +++ b/services/galley/package.yaml @@ -61,6 +61,7 @@ library: - http-media - http-types >=0.8 - insert-ordered-containers + - kan-extensions - lens >=4.4 - memory - metrics-wai >=0.4 @@ -193,6 +194,7 @@ executables: - http-client-tls - http-media - http-types + - kan-extensions - lens - lens-aeson - mtl diff --git a/services/galley/src/Galley/Run.hs b/services/galley/src/Galley/Run.hs index 7466522cfd3..21148ef78c0 100644 --- a/services/galley/src/Galley/Run.hs +++ b/services/galley/src/Galley/Run.hs @@ -27,6 +27,7 @@ import Cassandra.Schema (versionCheck) import qualified Control.Concurrent.Async as Async import Control.Exception (finally) import Control.Lens (view, (.~), (^.)) +import Control.Monad.Codensity import qualified Data.Aeson as Aeson import Data.Default import Data.Id @@ -59,45 +60,44 @@ import qualified Wire.API.Routes.Public.Galley as GalleyAPI import Wire.API.Routes.Version.Wai run :: Opts -> IO () -run o = do - (app, e, appFinalizer) <- mkApp o - let l = e ^. App.applog - s <- - newSettings $ - defaultServer - (unpack $ o ^. optGalley . epHost) - (portNumber $ fromIntegral $ o ^. optGalley . epPort) - l - (e ^. monitor) - deleteQueueThread <- Async.async $ runApp e deleteLoop - refreshMetricsThread <- Async.async $ runApp e refreshMetrics - runSettingsWithShutdown s app 5 `finally` do - Async.cancel deleteQueueThread - Async.cancel refreshMetricsThread - shutdown (e ^. cstate) - appFinalizer +run opts = lowerCodensity $ do + (app, env) <- mkApp opts + settings <- + lift $ + newSettings $ + defaultServer + (unpack $ opts ^. optGalley . epHost) + (portNumber $ fromIntegral $ opts ^. optGalley . epPort) + (env ^. App.applog) + (env ^. monitor) -mkApp :: Opts -> IO (Application, Env, IO ()) -mkApp o = do - m <- M.metrics - e <- App.createEnv m o - let l = e ^. App.applog - runClient (e ^. cstate) $ - versionCheck schemaVersion - let finalizer = do - Log.info l $ Log.msg @Text "Galley application finished." - Log.flush l - Log.close l - middlewares = - versionMiddleware - . servantPlusWAIPrometheusMiddleware API.sitemap (Proxy @CombinedAPI) - . GZip.gunzip - . GZip.gzip GZip.def - . catchErrors l [Right m] - return (middlewares $ servantApp e, e, finalizer) + void $ Codensity $ Async.withAsync $ runApp env deleteLoop + void $ Codensity $ Async.withAsync $ runApp env refreshMetrics + lift $ finally (runSettingsWithShutdown settings app 5) (shutdown (env ^. cstate)) + +mkApp :: Opts -> Codensity IO (Application, Env) +mkApp opts = + do + metrics <- lift $ M.metrics + env <- lift $ App.createEnv metrics opts + lift $ runClient (env ^. cstate) $ versionCheck schemaVersion + + let logger = env ^. App.applog + + let middlewares = + versionMiddleware + . servantPlusWAIPrometheusMiddleware API.sitemap (Proxy @CombinedAPI) + . GZip.gunzip + . GZip.gzip GZip.def + . catchErrors logger [Right metrics] + Codensity $ \k -> finally (k ()) $ do + Log.info logger $ Log.msg @Text "Galley application finished." + Log.flush logger + Log.close logger + pure (middlewares $ servantApp env, env) where rtree = compile API.sitemap - app e r k = evalGalley e (route rtree r k) + runGalley e r k = evalGalley e (route rtree r k) -- the servant API wraps the one defined using wai-routing servantApp e0 r = let e = reqId .~ lookupReqId r $ e0 @@ -110,7 +110,7 @@ mkApp o = do ( hoistAPIHandler (toServantHandler e) API.servantSitemap :<|> hoistAPIHandler (toServantHandler e) internalAPI :<|> hoistServerWithDomain @FederationAPI (toServantHandler e) federationSitemap - :<|> Servant.Tagged (app e) + :<|> Servant.Tagged (runGalley e) ) r diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index 2678707c584..40e2a423d6e 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -67,7 +67,7 @@ import Data.Time.Clock (getCurrentTime) import Federator.Discovery (DiscoveryFailure (..)) import Federator.MockServer (FederatedRequest (..), MockException (..)) import Galley.API.Mapping -import Galley.Options (Opts, optFederator) +import Galley.Options (optFederator) import Galley.Types hiding (LocalMember (..)) import Galley.Types.Conversations.Intra import Galley.Types.Conversations.Members @@ -2021,13 +2021,12 @@ postConvQualifiedNonExistentDomain = do postConvQualifiedFederationNotEnabled :: TestM () postConvQualifiedFederationNotEnabled = do - g <- view tsGalley alice <- randomUser bob <- flip Qualified (Domain "some-remote-backend.example.com") <$> randomId - opts <- view tsGConf connectWithRemoteUser alice bob - let federatorNotConfigured :: Opts = opts & optFederator .~ Nothing - withSettingsOverrides federatorNotConfigured $ + let federatorNotConfigured = optFederator .~ Nothing + withSettingsOverrides federatorNotConfigured $ do + g <- view tsGalley postConvHelper g alice [bob] !!! do const 400 === statusCode const (Just "federation-not-enabled") === fmap label . responseJsonUnsafe @@ -2585,10 +2584,9 @@ testAddRemoteMemberFederationDisabled = do convId <- decodeConvId <$> postConv alice [] (Just "remote gossip") [] Nothing Nothing connectWithRemoteUser alice remoteBob - opts <- view tsGConf -- federator endpoint not configured is equivalent to federation being disabled -- This is the case on staging/production in May 2021. - let federatorNotConfigured :: Opts = opts & optFederator .~ Nothing + let federatorNotConfigured = optFederator .~ Nothing withSettingsOverrides federatorNotConfigured $ postQualifiedMembers alice (remoteBob :| []) convId !!! do const 400 === statusCode @@ -2605,12 +2603,11 @@ testAddRemoteMemberFederationUnavailable = do convId <- decodeConvId <$> postConv alice [] (Just "remote gossip") [] Nothing Nothing connectWithRemoteUser alice remoteBob - opts <- view tsGConf -- federator endpoint being configured in brig and/or galley, but not being -- available (i.e. no service listing on that IP/port) can happen due to a -- misconfiguration of federator. That should give a 500. -- Port 1 should always be wrong hopefully. - let federatorUnavailable :: Opts = opts & optFederator ?~ Endpoint "127.0.0.1" 1 + let federatorUnavailable = optFederator ?~ Endpoint "127.0.0.1" 1 withSettingsOverrides federatorUnavailable $ postQualifiedMembers alice (remoteBob :| []) convId !!! do const 500 === statusCode diff --git a/services/galley/test/integration/API/Federation.hs b/services/galley/test/integration/API/Federation.hs index a68d428dd83..0918e4acc25 100644 --- a/services/galley/test/integration/API/Federation.hs +++ b/services/galley/test/integration/API/Federation.hs @@ -23,7 +23,6 @@ import API.MLS.Util import API.Util import Bilge import Bilge.Assert -import Bilge.TestSession (liftSession) import Control.Lens hiding ((#)) import Data.Aeson (ToJSON (..)) import qualified Data.Aeson as A @@ -1088,11 +1087,9 @@ updateConversationByRemoteAdmin = do curConvId = qUnqualified cnv, curAction = action } - resp <- - liftSession $ - runWaiTestFedClient bdomain $ - createWaiTestFedClient @"update-conversation" @'Galley $ - cnvUpdateRequest + resp <- do + fedGalleyClient <- view tsFedGalleyClient + runFedClient @"update-conversation" fedGalleyClient bdomain cnvUpdateRequest cnvUpdate' <- liftIO $ case resp of ConversationUpdateResponseError err -> assertFailure ("Expected ConversationUpdateResponseUpdate but got " <> show err) diff --git a/services/galley/test/integration/API/Teams.hs b/services/galley/test/integration/API/Teams.hs index 64510e7a08d..3b2623515eb 100644 --- a/services/galley/test/integration/API/Teams.hs +++ b/services/galley/test/integration/API/Teams.hs @@ -449,27 +449,30 @@ testEnableSSOPerTeam = do testEnableTeamSearchVisibilityPerTeam :: TestM () testEnableTeamSearchVisibilityPerTeam = do - g <- view tsGalley (tid, owner, member : _) <- Util.createBindingTeamWithMembers 2 - let check :: (HasCallStack, MonadCatch m, MonadIO m, Monad m, MonadHttp m) => String -> Public.TeamFeatureStatusValue -> m () + let check :: String -> Public.TeamFeatureStatusValue -> TestM () check msg enabledness = do + g <- view tsGalley status :: Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureSearchVisibility <- responseJsonUnsafe <$> (Util.getTeamSearchVisibilityAvailableInternal g tid m () + let putSearchVisibilityCheckNotAllowed :: TestM () putSearchVisibilityCheckNotAllowed = do + g <- view tsGalley Wai.Error status label _ _ <- responseJsonUnsafe <$> putSearchVisibility g owner tid SearchVisibilityNoNameOutsideTeam liftIO $ do assertEqual "bad status" status403 status assertEqual "bad label" "team-search-visibility-not-enabled" label - let getSearchVisibilityCheck :: (HasCallStack, MonadCatch m, MonadIO m, MonadHttp m) => TeamSearchVisibility -> m () - getSearchVisibilityCheck vis = + let getSearchVisibilityCheck :: TeamSearchVisibility -> TestM () + getSearchVisibilityCheck vis = do + g <- view tsGalley getSearchVisibility g owner tid !!! do const 200 === statusCode const (Just (TeamSearchVisibilityView vis)) === responseJsonUnsafe Util.withCustomSearchFeature FeatureTeamSearchVisibilityEnabledByDefault $ do + g <- view tsGalley check "Teams should start with Custom Search Visibility enabled" Public.TeamFeatureEnabled putSearchVisibility g owner tid SearchVisibilityNoNameOutsideTeam !!! const 204 === statusCode putSearchVisibility g owner tid SearchVisibilityStandard !!! const 204 === statusCode @@ -477,6 +480,7 @@ testEnableTeamSearchVisibilityPerTeam = do check "Teams should start with Custom Search Visibility disabled" Public.TeamFeatureDisabled putSearchVisibilityCheckNotAllowed + g <- view tsGalley Util.putTeamSearchVisibilityAvailableInternal g tid Public.TeamFeatureEnabled -- Nothing was set, default value getSearchVisibilityCheck SearchVisibilityStandard @@ -1669,7 +1673,7 @@ testBillingInLargeTeamWithoutIndexedBillingTeamMembers = do opts <- view tsGConf galley <- view tsGalley let withoutIndexedBillingTeamMembers = - withSettingsOverrides (opts & optSettings . setEnableIndexedBillingTeamMembers ?~ False) + withSettingsOverrides (\o -> o & optSettings . setEnableIndexedBillingTeamMembers ?~ False) let fanoutLimit = fromRange $ Galley.currentFanoutLimit opts -- Billing should work properly upto fanout limit @@ -1698,8 +1702,9 @@ testBillingInLargeTeamWithoutIndexedBillingTeamMembers = do let memFanoutPlusTwo = json $ Member.mkNewTeamMember ownerFanoutPlusTwo (rolePermissions RoleOwner) Nothing -- We cannot properly add the new owner with an invite as we don't have a way to -- override galley settings while making a call to brig - withoutIndexedBillingTeamMembers $ - post (galley . paths ["i", "teams", toByteString' team, "members"] . memFanoutPlusTwo) + withoutIndexedBillingTeamMembers $ do + g <- view tsGalley + post (g . paths ["i", "teams", toByteString' team, "members"] . memFanoutPlusTwo) !!! const 200 === statusCode assertQueue ("add " <> show (fanoutLimit + 2) <> "th billing member: " <> show ownerFanoutPlusTwo) $ \s maybeEvent -> @@ -1908,7 +1913,6 @@ postCryptoBroadcastMessageFilteredTooLargeTeam bcast = do localDomain <- viewFederationDomain let q :: Id a -> Qualified (Id a) q = (`Qualified` localDomain) - opts <- view tsGConf c <- view tsCannon -- Team1: alice, bob and 3 unnamed (alice, tid) <- Util.createBindingTeam @@ -1943,8 +1947,8 @@ postCryptoBroadcastMessageFilteredTooLargeTeam bcast = do WS.bracketR (c . queryItem "client" (toByteString' ac)) alice $ \wsA1 -> do -- We change also max conv size due to the invariants that galley forces us to keep let newOpts = - opts & optSettings . setMaxFanoutSize .~ Just (unsafeRange 4) - & optSettings . setMaxConvSize .~ 4 + ((optSettings . setMaxFanoutSize) ?~ unsafeRange 4) + . (optSettings . setMaxConvSize .~ 4) withSettingsOverrides newOpts $ do -- Untargeted, Alice's team is too large Util.postBroadcast (q alice) ac bcast {bMessage = msg} !!! do diff --git a/services/galley/test/integration/API/Teams/Feature.hs b/services/galley/test/integration/API/Teams/Feature.hs index dfd3af3c2da..0f529b85dc4 100644 --- a/services/galley/test/integration/API/Teams/Feature.hs +++ b/services/galley/test/integration/API/Teams/Feature.hs @@ -172,43 +172,31 @@ testSearchVisibility = do Util.connectUsers owner (list1 member []) Util.addTeamMember owner tid member (rolePermissions RoleMember) Nothing - g <- view tsGalley - let getTeamSearchVisibility :: - (Monad m, MonadHttp m, MonadIO m, MonadCatch m, HasCallStack) => - TeamId -> - Public.TeamFeatureStatusValue -> - m () - getTeamSearchVisibility teamid expected = + let getTeamSearchVisibility :: TeamId -> Public.TeamFeatureStatusValue -> TestM () + getTeamSearchVisibility teamid expected = do + g <- view tsGalley Util.getTeamSearchVisibilityAvailable g owner teamid !!! do statusCode === const 200 responseJsonEither === const (Right (Public.TeamFeatureStatusNoConfig expected)) - let getTeamSearchVisibilityInternal :: - (Monad m, MonadHttp m, MonadIO m, MonadCatch m, HasCallStack) => - TeamId -> - Public.TeamFeatureStatusValue -> - m () - getTeamSearchVisibilityInternal teamid expected = + let getTeamSearchVisibilityInternal :: TeamId -> Public.TeamFeatureStatusValue -> TestM () + getTeamSearchVisibilityInternal teamid expected = do + g <- view tsGalley Util.getTeamSearchVisibilityAvailableInternal g teamid !!! do statusCode === const 200 responseJsonEither === const (Right (Public.TeamFeatureStatusNoConfig expected)) - let getTeamSearchVisibilityFeatureConfig :: - (Monad m, MonadHttp m, MonadIO m, MonadCatch m, HasCallStack) => - UserId -> - Public.TeamFeatureStatusValue -> - m () - getTeamSearchVisibilityFeatureConfig uid expected = + let getTeamSearchVisibilityFeatureConfig :: UserId -> Public.TeamFeatureStatusValue -> TestM () + getTeamSearchVisibilityFeatureConfig uid expected = do + g <- view tsGalley Util.getFeatureConfigWithGalley Public.TeamFeatureSearchVisibility g uid !!! do statusCode === const 200 responseJsonEither === const (Right (Public.TeamFeatureStatusNoConfig expected)) - let setTeamSearchVisibilityInternal :: - (Monad m, MonadHttp m, MonadIO m, HasCallStack) => - TeamId -> - Public.TeamFeatureStatusValue -> - m () - setTeamSearchVisibilityInternal = Util.putTeamSearchVisibilityAvailableInternal g + let setTeamSearchVisibilityInternal :: TeamId -> Public.TeamFeatureStatusValue -> TestM () + setTeamSearchVisibilityInternal teamid val = do + g <- view tsGalley + Util.putTeamSearchVisibilityAvailableInternal g teamid val assertFlagForbidden $ Util.getTeamFeatureFlag Public.TeamFeatureSearchVisibility nonMember tid @@ -311,8 +299,7 @@ testClassifiedDomainsDisabled = do assertFlagWithConfig @Public.TeamFeatureClassifiedDomainsConfig $ Util.getFeatureConfig Public.TeamFeatureClassifiedDomains uid - opts <- view tsGConf - let classifiedDomainsDisabled = + let classifiedDomainsDisabled = \opts -> opts & over (optSettings . setFeatureFlags . flagClassifiedDomains) diff --git a/services/galley/test/integration/API/Teams/LegalHold.hs b/services/galley/test/integration/API/Teams/LegalHold.hs index 048efe592d8..c44dab965b4 100644 --- a/services/galley/test/integration/API/Teams/LegalHold.hs +++ b/services/galley/test/integration/API/Teams/LegalHold.hs @@ -29,7 +29,6 @@ import qualified API.SQS as SQS import API.Util import Bilge hiding (accept, head, timeout, trace) import Bilge.Assert -import qualified Bilge.TestSession as BilgeTest import Brig.Types.Client import Brig.Types.Intra (UserSet (..)) import Brig.Types.Provider @@ -1564,11 +1563,11 @@ withDummyTestServiceForTeamNoService go = do -- it's here for historical reason because we did this in galley.yaml -- at some point in the past rather than in an internal end-point, and that required spawning -- another galley 'Application' with 'withSettingsOverrides'. -withLHWhitelist :: forall a. HasCallStack => TeamId -> BilgeTest.SessionT TestM a -> TestM a +withLHWhitelist :: forall a. HasCallStack => TeamId -> TestM a -> TestM a withLHWhitelist tid action = do void $ putLHWhitelistTeam tid opts <- view tsGConf - withSettingsOverrides opts action + withSettingsOverrides (const opts) action -- | If you play with whitelists, you should use this one. Every whitelisted team that does -- not get fully deleted will blow up the whitelist that is cached in every warp handler. diff --git a/services/galley/test/integration/API/Util.hs b/services/galley/test/integration/API/Util.hs index f72eb36c8e6..3f4bddeaa88 100644 --- a/services/galley/test/integration/API/Util.hs +++ b/services/galley/test/integration/API/Util.hs @@ -30,15 +30,14 @@ import Brig.Types.User.Auth (CookieLabel (..)) import Control.Concurrent.Async import Control.Exception (throw) import Control.Lens hiding (from, to, (#), (.=)) -import Control.Monad.Catch (MonadCatch, MonadMask, finally) +import Control.Monad.Catch (MonadCatch, MonadMask) +import Control.Monad.Codensity (lowerCodensity) import Control.Monad.Except (ExceptT, runExceptT) import Control.Retry (constantDelay, exponentialBackoff, limitRetries, retrying) import Data.Aeson hiding (json) import Data.Aeson.Lens (key, _String) import qualified Data.ByteString as BS -import Data.ByteString.Builder (toLazyByteString) import qualified Data.ByteString.Char8 as C -import qualified Data.ByteString.Char8 as C8 import Data.ByteString.Conversion import qualified Data.ByteString.Lazy as Lazy import qualified Data.CaseInsensitive as CI @@ -60,7 +59,6 @@ import qualified Data.ProtoLens as Protolens import Data.ProtocolBuffers (encodeMessage) import Data.Qualified import Data.Range -import qualified Data.Sequence as Seq import Data.Serialize (runPut) import qualified Data.Set as Set import Data.Singletons @@ -74,7 +72,6 @@ import qualified Data.UUID as UUID import Data.UUID.V4 import Federator.MockServer (FederatedRequest (..)) import qualified Federator.MockServer as Mock -import GHC.TypeLits import Galley.Intra.User (chunkify) import qualified Galley.Options as Opts import qualified Galley.Run as Run @@ -89,19 +86,12 @@ import Galley.Types.Teams.Intra import Galley.Types.UserList import Imports import Network.HTTP.Media.MediaType -import Network.HTTP.Media.RenderHeader (renderHeader) -import Network.HTTP.Types (http11, renderQuery) import qualified Network.HTTP.Types as HTTP import Network.Wai (Application, defaultRequest) import qualified Network.Wai as Wai import qualified Network.Wai.Test as Wai -import qualified Network.Wai.Test as WaiTest +import Network.Wai.Utilities.MockServer (withMockServer) import Servant (Handler, HasServer, Server, ServerT, serve, (:<|>) (..)) -import Servant.Client (ClientError (FailureResponse)) -import qualified Servant.Client as Servant -import Servant.Client.Core (RunClient (throwClientError)) -import qualified Servant.Client.Core as Servant -import qualified Servant.Client.Core.Request as ServantRequest import System.Exit import System.Process import System.Random @@ -661,10 +651,9 @@ defNewMLSConv :: NewConv defNewMLSConv = defNewProteusConv {newConvProtocol = ProtocolMLSTag} postConvQualified :: - (HasCallStack, HasGalley m, MonadIO m, MonadMask m, MonadHttp m) => UserId -> NewConv -> - m ResponseLBS + TestM ResponseLBS postConvQualified u n = do g <- viewGalley post $ @@ -2338,14 +2327,20 @@ postSSOUser name hasEmail ssoid teamid = do defCookieLabel :: CookieLabel defCookieLabel = CookieLabel "auth" --- | This allows you to run requests against a galley instantiated using the given options. --- Note that ONLY 'galley' calls should occur within the provided action, calls to other --- services will fail. -withSettingsOverrides :: (HasGalley m, MonadIO m, MonadMask m) => Opts.Opts -> SessionT m a -> m a -withSettingsOverrides opts action = do - (galleyApp, _, finalizer) <- liftIO $ Run.mkApp opts - runSessionT action galleyApp - `finally` liftIO finalizer +withSettingsOverrides :: (Opts.Opts -> Opts.Opts) -> TestM a -> TestM a +withSettingsOverrides f action = do + ts :: TestSetup <- ask + let opts = f (ts ^. tsGConf) + liftIO . lowerCodensity $ do + (galleyApp, _env) <- Run.mkApp opts + port' <- withMockServer galleyApp + liftIO $ + runReaderT + (runTestM action) + ( ts + & tsGalley .~ Bilge.host "127.0.0.1" . Bilge.port port' + & tsFedGalleyClient .~ FedClient (ts ^. tsManager) (Endpoint "127.0.0.1" port') + ) waitForMemberDeletion :: UserId -> TeamId -> UserId -> TestM () waitForMemberDeletion zusr tid uid = do @@ -2483,36 +2478,30 @@ mkProfile quid name = -- federator response (of an arbitrary JSON-serialisable type a) for every -- expected request. withTempMockFederator :: - (MonadIO m, ToJSON a, HasGalley m, MonadMask m) => + ToJSON a => (FederatedRequest -> a) -> - SessionT m b -> - m (b, [FederatedRequest]) + TestM b -> + TestM (b, [FederatedRequest]) withTempMockFederator resp = withTempMockFederator' $ pure . encode . resp withTempMockFederator' :: - (MonadIO m, HasGalley m, MonadMask m) => (FederatedRequest -> IO LByteString) -> - SessionT m b -> - m (b, [FederatedRequest]) + TestM b -> + TestM (b, [FederatedRequest]) withTempMockFederator' resp action = do - opts <- viewGalleyOpts Mock.withTempMockFederator [("Content-Type", "application/json")] ((\r -> pure ("application" // "json", r)) <=< resp) $ \mockPort -> do - let opts' = - opts & Opts.optFederator - ?~ Endpoint "127.0.0.1" (fromIntegral mockPort) - withSettingsOverrides opts' action + withSettingsOverrides (\opts -> opts & Opts.optFederator ?~ Endpoint "127.0.0.1" (fromIntegral mockPort)) action -- Start a mock federator. Use proveded Servant handler for the mocking mocking function. withTempServantMockFederator :: - (MonadMask m, MonadIO m, HasGalley m) => (Domain -> ServerT (FedApi 'Brig) Handler) -> (Domain -> ServerT (FedApi 'Galley) Handler) -> Domain -> - SessionT m b -> - m (b, [FederatedRequest]) + TestM b -> + TestM (b, [FederatedRequest]) withTempServantMockFederator brigApi galleyApi originDomain = withTempMockFederator' mock where @@ -2793,90 +2782,3 @@ wsAssertConvReceiptModeUpdate conv usr new n = do evtType e @?= ConvReceiptModeUpdate evtFrom e @?= usr evtData e @?= EdConvReceiptModeUpdate (ConversationReceiptModeUpdate new) - -newtype WaiTestFedClient a = WaiTestFedClient {unWaiTestFedClient :: ReaderT Domain WaiTest.Session a} - deriving (Functor, Applicative, Monad, MonadIO) - -instance Servant.RunClient WaiTestFedClient where - runRequestAcceptStatus expectedStatuses servantRequest = WaiTestFedClient $ do - domain <- ask - let req' = fromServantRequest domain servantRequest - res <- lift $ WaiTest.srequest req' - let servantResponse = toServantResponse res - let status = Servant.responseStatusCode servantResponse - let statusIsSuccess = - case expectedStatuses of - Nothing -> HTTP.statusIsSuccessful status - Just ex -> status `elem` ex - unless statusIsSuccess $ - unWaiTestFedClient $ throwClientError (FailureResponse (bimap (const ()) (\x -> (Servant.BaseUrl Servant.Http "" 80 "", cs (toLazyByteString x))) servantRequest) servantResponse) - pure servantResponse - throwClientError = liftIO . throw - -fromServantRequest :: Domain -> Servant.Request -> WaiTest.SRequest -fromServantRequest domain r = - let pathBS = "/federation" <> Data.String.Conversions.cs (toLazyByteString (Servant.requestPath r)) - bodyBS = case Servant.requestBody r of - Nothing -> "" - Just (bdy, _) -> case bdy of - Servant.RequestBodyLBS lbs -> Data.String.Conversions.cs lbs - Servant.RequestBodyBS bs -> bs - Servant.RequestBodySource _ -> error "fromServantRequest: not implemented for RequestBodySource" - - -- Content-Type and Accept are specified by requestBody and requestAccept - headers = - filter (\(h, _) -> h /= "Accept" && h /= "Content-Type") $ - toList $ Servant.requestHeaders r - acceptHdr - | null hs = Nothing - | otherwise = Just ("Accept", renderHeader hs) - where - hs = toList $ ServantRequest.requestAccept r - contentTypeHdr = case ServantRequest.requestBody r of - Nothing -> Nothing - Just (_', typ) -> Just (HTTP.hContentType, renderHeader typ) - req = - Wai.defaultRequest - { Wai.requestMethod = Servant.requestMethod r, - Wai.rawPathInfo = pathBS, - Wai.rawQueryString = renderQuery True (toList (Servant.requestQueryString r)), - Wai.requestHeaders = - -- Inspired by 'Servant.Client.Internal.HttpClient.defaultMakeClientRequest', - -- the Servant function that maps @Request@ to @Client.Request@. - -- This solution is a bit sophisticated due to two constraints: - -- - Accept header may contain a list of accepted media types. - -- - Accept and Content-Type headers should only appear once in the result. - maybeToList acceptHdr - <> maybeToList contentTypeHdr - <> headers - <> [(originDomainHeaderName, Text.encodeUtf8 (domainText domain))], - Wai.isSecure = True, - Wai.pathInfo = filter (not . Text.null) (map Data.String.Conversions.cs (C8.split '/' pathBS)), - Wai.queryString = toList (Servant.requestQueryString r) - } - in WaiTest.SRequest req (cs bodyBS) - -toServantResponse :: WaiTest.SResponse -> Servant.Response -toServantResponse res = - Servant.Response - { Servant.responseStatusCode = WaiTest.simpleStatus res, - Servant.responseHeaders = Seq.fromList (WaiTest.simpleHeaders res), - Servant.responseBody = WaiTest.simpleBody res, - Servant.responseHttpVersion = http11 - } - -createWaiTestFedClient :: - forall (name :: Symbol) comp api. - ( HasFedEndpoint comp api name, - Servant.HasClient WaiTestFedClient api - ) => - Servant.Client WaiTestFedClient api -createWaiTestFedClient = - Servant.clientIn (Proxy @api) (Proxy @WaiTestFedClient) - -runWaiTestFedClient :: - Domain -> - WaiTestFedClient a -> - WaiTest.Session a -runWaiTestFedClient domain action = - runReaderT (unWaiTestFedClient action) domain diff --git a/services/galley/test/integration/API/Util/TeamFeature.hs b/services/galley/test/integration/API/Util/TeamFeature.hs index e97a13d4fad..38248390266 100644 --- a/services/galley/test/integration/API/Util/TeamFeature.hs +++ b/services/galley/test/integration/API/Util/TeamFeature.hs @@ -20,7 +20,6 @@ module API.Util.TeamFeature where import API.Util (HasGalley (viewGalley), zUser) import qualified API.Util as Util import Bilge -import qualified Bilge.TestSession as BilgeTest import Control.Lens (view, (.~)) import Data.Aeson (ToJSON) import Data.ByteString.Conversion (toByteString') @@ -31,11 +30,9 @@ import Imports import TestSetup import qualified Wire.API.Team.Feature as Public -withCustomSearchFeature :: FeatureTeamSearchVisibility -> BilgeTest.SessionT TestM () -> TestM () +withCustomSearchFeature :: FeatureTeamSearchVisibility -> TestM () -> TestM () withCustomSearchFeature flag action = do - opts <- view tsGConf - let opts' = opts & optSettings . setFeatureFlags . flagTeamSearchVisibility .~ flag - Util.withSettingsOverrides opts' action + Util.withSettingsOverrides (\opts -> opts & optSettings . setFeatureFlags . flagTeamSearchVisibility .~ flag) action getTeamSearchVisibilityAvailable :: HasCallStack => (Request -> Request) -> UserId -> TeamId -> (MonadIO m, MonadHttp m) => m ResponseLBS getTeamSearchVisibilityAvailable = getTeamFeatureFlagWithGalley Public.TeamFeatureSearchVisibility