galley: refactor withSettingsOverrides (#2381)

Co-authored-by: Paolo Capriotti <[email protected]>

changelog.d/5-internal/galley-no-sessiont

@@ -0,0 +1 @@
+galley: refactor withSettingsOverrides

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

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

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
 

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

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)

services/galley/test/integration/API/Teams.hs

@@ -449,34 +449,38 @@ 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 <!! testResponse 200 Nothing)
         let statusValue = Public.tfwoStatus status
 
         liftIO $ assertEqual msg enabledness statusValue
-  let putSearchVisibilityCheckNotAllowed :: (HasCallStack, Monad m, MonadIO m, MonadHttp m) => 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
   Util.withCustomSearchFeature FeatureTeamSearchVisibilityDisabledByDefault $ 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

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)

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.