Legalhold: Remove caching for whitelisted teams

services/galley/src/Galley/API/Internal.hs

@@ -38,7 +38,7 @@ import Data.String.Conversions (cs)
 import qualified Galley.API.Clients as Clients
 import qualified Galley.API.Create as Create
 import qualified Galley.API.CustomBackend as CustomBackend
-import Galley.API.LegalHold (getLegalholdWhitelistedTeamsH, setTeamLegalholdWhitelistedH, unsetTeamLegalholdWhitelistedH)
+import Galley.API.LegalHold (getTeamLegalholdWhitelistedH, setTeamLegalholdWhitelistedH, unsetTeamLegalholdWhitelistedH)
 import qualified Galley.API.Query as Query
 import Galley.API.Teams (uncheckedDeleteTeamMember)
 import qualified Galley.API.Teams as Teams
@@ -274,15 +274,15 @@ sitemap = do
     jsonRequest @GuardLegalholdPolicyConflicts
       .&. accept "application" "json"
 
-  get "/i/legalhold/whitelisted-teams" (continue getLegalholdWhitelistedTeamsH) $
-    accept "application" "json"
-
   put "/i/legalhold/whitelisted-teams/:tid" (continue setTeamLegalholdWhitelistedH) $
     capture "tid"
 
   delete "/i/legalhold/whitelisted-teams/:tid" (continue unsetTeamLegalholdWhitelistedH) $
     capture "tid"
 
+  get "/i/legalhold/whitelisted-teams/:tid" (continue getTeamLegalholdWhitelistedH) $
+    capture "tid"
+
 rmUserH :: UserId ::: Maybe ConnId -> Galley Response
 rmUserH (user ::: conn) = do
   empty <$ rmUser user conn

services/galley/src/Galley/API/LegalHold.hs

@@ -26,9 +26,9 @@ module Galley.API.LegalHold
     approveDeviceH,
     disableForUserH,
     isLegalHoldEnabledForTeam,
-    getLegalholdWhitelistedTeamsH,
     setTeamLegalholdWhitelistedH,
     unsetTeamLegalholdWhitelistedH,
+    getTeamLegalholdWhitelistedH,
   )
 where
 
@@ -49,6 +49,7 @@ import Galley.API.Error
 import Galley.API.Util
 import Galley.App
 import qualified Galley.Data as Data
+import Galley.Data.LegalHold (isTeamLegalholdWhitelisted)
 import qualified Galley.Data.LegalHold as LegalHoldData
 import qualified Galley.Data.TeamFeatures as TeamFeatures
 import qualified Galley.External.LegalHoldService as LHService
@@ -57,7 +58,7 @@ import Galley.Intra.User (getConnections, putConnectionInternal)
 import qualified Galley.Options as Opts
 import Galley.Types.Teams as Team
 import Imports
-import Network.HTTP.Types (status200)
+import Network.HTTP.Types (status200, status404)
 import Network.HTTP.Types.Status (status201, status204)
 import Network.Wai
 import Network.Wai.Predicate hiding (or, result, setStatus, _3)
@@ -81,11 +82,8 @@ isLegalHoldEnabledForTeam tid = do
         Just Public.TeamFeatureEnabled -> True
         Just Public.TeamFeatureDisabled -> False
         Nothing -> False
-    FeatureLegalHoldWhitelistTeamsAndImplicitConsent -> do
-      (readIORef =<< view legalholdWhitelist)
-        <&> maybe
-          False {- reasonable default, even though this is impossible due to "Galley.Options.validateOpts" -}
-          (tid `elem`)
+    FeatureLegalHoldWhitelistTeamsAndImplicitConsent ->
+      isTeamLegalholdWhitelisted tid
 
 createSettingsH :: UserId ::: TeamId ::: JsonRequest Public.NewLegalHoldService ::: JSON -> Galley Response
 createSettingsH (zusr ::: tid ::: req ::: _) = do
@@ -447,14 +445,6 @@ blockConnectionsFrom1on1s uid = do
             mMember <- Data.teamMember team other
             pure $ maybe defUserLegalHoldStatus (view legalHoldStatus) mMember
 
-getLegalholdWhitelistedTeams :: Galley [TeamId]
-getLegalholdWhitelistedTeams = do
-  fromMaybe [] <$> (readIORef =<< view legalholdWhitelist)
-
-getLegalholdWhitelistedTeamsH :: JSON -> Galley Response
-getLegalholdWhitelistedTeamsH _ = do
-  json <$> getLegalholdWhitelistedTeams
-
 setTeamLegalholdWhitelisted :: TeamId -> Galley ()
 setTeamLegalholdWhitelisted tid = do
   LegalHoldData.setTeamLegalholdWhitelisted tid
@@ -475,3 +465,11 @@ unsetTeamLegalholdWhitelistedH tid = do
       \number of LH devices as well, and possibly other things.  think this through \
       \before you enable the end-point."
   setStatus status204 empty <$ unsetTeamLegalholdWhitelisted tid
+
+getTeamLegalholdWhitelistedH :: TeamId -> Galley Response
+getTeamLegalholdWhitelistedH tid = do
+  lhEnabled <- isLegalHoldEnabledForTeam tid
+  pure $
+    if lhEnabled
+      then setStatus status204 empty
+      else setStatus status404 empty

services/galley/src/Galley/App.hs

@@ -32,7 +32,6 @@ module Galley.App
     createEnv,
     extEnv,
     aEnv,
-    legalholdWhitelist,
     ExtEnv (..),
     extGetManager,
 
@@ -114,11 +113,7 @@ data Env = Env
     _cstate :: ClientState,
     _deleteQueue :: Q.Queue DeleteItem,
     _extEnv :: ExtEnv,
-    _aEnv :: Maybe Aws.Env,
-    -- | A cache of cassandra table `galley.legalhold_whitelisted`, read once for every
-    -- request.  (This is not ideal, but it's better than reading it once per member that is
-    -- looked at, which can be hundrets or thousands of times in many requests.)
-    _legalholdWhitelist :: IORef (Maybe [TeamId])
+    _aEnv :: Maybe Aws.Env
   }
 
 -- | Environment specific to the communication with external
@@ -201,8 +196,8 @@ instance MonadHttp Galley where
 instance HasRequestId Galley where
   getRequestId = view reqId
 
-createEnv :: (ClientState -> Opts -> IO (Maybe [TeamId])) -> Metrics -> Opts -> IO Env
-createEnv mkLegalholdWhitelist m o = do
+createEnv :: Metrics -> Opts -> IO Env
+createEnv m o = do
   l <- Logger.mkLogger (o ^. optLogLevel) (o ^. optLogNetStrings) (o ^. optLogFormat)
   cass <- initCassandra o l
   mgr <- initHttpManager o
@@ -211,7 +206,6 @@ createEnv mkLegalholdWhitelist m o = do
     <$> Q.new 16000
     <*> initExtEnv
     <*> maybe (return Nothing) (fmap Just . Aws.mkEnv l mgr) (o ^. optJournal)
-    <*> (newIORef =<< mkLegalholdWhitelist cass o)
 
 initCassandra :: Opts -> Logger -> IO ClientState
 initCassandra o l = do

services/galley/src/Galley/Data.hs

@@ -114,6 +114,7 @@ import Control.Arrow (first, second)
 import Control.Exception (ErrorCall (ErrorCall))
 import Control.Lens hiding ((<|))
 import Control.Monad.Catch (MonadThrow, throwM)
+import Control.Monad.Extra (ifM)
 import Data.ByteString.Conversion hiding (parser)
 import Data.Domain (Domain)
 import Data.Id as Id
@@ -133,6 +134,7 @@ import qualified Data.UUID.Tagged as U
 import Data.UUID.V4 (nextRandom)
 import Galley.App
 import Galley.Data.Instances ()
+import Galley.Data.LegalHold (isTeamLegalholdWhitelisted)
 import qualified Galley.Data.Queries as Cql
 import Galley.Data.Types as Data
 import Galley.Types hiding (Conversation)
@@ -1018,14 +1020,16 @@ eraseClients user = retry x5 (write Cql.rmClients (params Quorum (Identity user)
 --
 -- Throw an exception if one of invitation timestamp and inviter is 'Nothing' and the
 -- other is 'Just', which can only be caused by inconsistent database content.
-newTeamMember' :: (MonadIO m, MonadThrow m, MonadReader Env m) => TeamId -> (UserId, Permissions, Maybe UserId, Maybe UTCTimeMillis, Maybe UserLegalHoldStatus) -> m TeamMember
+newTeamMember' :: (MonadIO m, MonadThrow m, MonadClient m, MonadReader Env m) => TeamId -> (UserId, Permissions, Maybe UserId, Maybe UTCTimeMillis, Maybe UserLegalHoldStatus) -> m TeamMember
 newTeamMember' tid (uid, perms, minvu, minvt, fromMaybe defUserLegalHoldStatus -> lhStatus) = do
-  mbWhitelist <- readIORef =<< view legalholdWhitelist
-  maybeGrant mbWhitelist <$> mk minvu minvt
+  mk minvu minvt >>= maybeGrant
   where
-    maybeGrant :: Maybe [TeamId] -> TeamMember -> TeamMember
-    maybeGrant Nothing = id
-    maybeGrant (Just whitelist) = if tid `elem` whitelist then grantImplicitConsent else id
+    maybeGrant :: (MonadClient m, MonadReader Env m) => TeamMember -> m TeamMember
+    maybeGrant m =
+      ifM
+        (isTeamLegalholdWhitelisted tid)
+        (pure (grantImplicitConsent m))
+        (pure m)
 
     grantImplicitConsent :: TeamMember -> TeamMember
     grantImplicitConsent =

services/galley/src/Galley/Data/LegalHold.hs

@@ -25,8 +25,8 @@ module Galley.Data.LegalHold
     Galley.Data.LegalHold.selectPendingPrekeys,
     Galley.Data.LegalHold.dropPendingPrekeys,
     setUserLegalHoldStatus,
-    getLegalholdWhitelistedTeams,
     setTeamLegalholdWhitelisted,
+    isTeamLegalholdWhitelisted,
     unsetTeamLegalholdWhitelisted,
   )
 where
@@ -35,11 +35,14 @@ import Brig.Types.Client.Prekey
 import Brig.Types.Instances ()
 import Brig.Types.Team.LegalHold
 import Cassandra
-import Control.Lens (unsnoc)
+import Control.Lens (unsnoc, view)
 import Data.Id
 import Data.LegalHold
+import Galley.App (Env, options)
 import Galley.Data.Instances ()
 import Galley.Data.Queries as Q
+import qualified Galley.Options as Opts
+import Galley.Types.Teams (FeatureLegalHold (..), flagLegalHold)
 import Imports
 
 -- | Returns 'False' if legal hold is not enabled for this team
@@ -86,16 +89,18 @@ setUserLegalHoldStatus :: MonadClient m => TeamId -> UserId -> UserLegalHoldStat
 setUserLegalHoldStatus tid uid status =
   retry x5 (write Q.updateUserLegalHoldStatus (params Quorum (status, tid, uid)))
 
--- | This is cached for every request in 'Galley.App.Env', so you probably don't want to call
--- it anywhere else.
-getLegalholdWhitelistedTeams :: MonadClient m => m [TeamId]
-getLegalholdWhitelistedTeams =
-  runIdentity <$$> retry x1 (query Q.selectLegalHoldWhitelistedTeams (params Quorum ()))
-
 setTeamLegalholdWhitelisted :: MonadClient m => TeamId -> m ()
 setTeamLegalholdWhitelisted tid =
   retry x5 (write Q.insertLegalHoldWhitelistedTeam (params Quorum (Identity tid)))
 
 unsetTeamLegalholdWhitelisted :: MonadClient m => TeamId -> m ()
 unsetTeamLegalholdWhitelisted tid =
   retry x5 (write Q.removeLegalHoldWhitelistedTeam (params Quorum (Identity tid)))
+
+isTeamLegalholdWhitelisted :: (MonadReader Env m, MonadClient m) => TeamId -> m Bool
+isTeamLegalholdWhitelisted tid = do
+  view (options . Opts.optSettings . Opts.setFeatureFlags . flagLegalHold) >>= \case
+    FeatureLegalHoldDisabledPermanently -> pure False
+    FeatureLegalHoldDisabledByDefault -> pure False
+    FeatureLegalHoldWhitelistTeamsAndImplicitConsent ->
+      isJust <$> (runIdentity <$$> retry x5 (query1 Q.selectLegalHoldWhitelistedTeam (params Quorum (Identity tid))))

services/galley/src/Galley/Data/Queries.hs

@@ -399,12 +399,6 @@ updateUserLegalHoldStatus =
           where team = ? and user = ?
     |]
 
-selectLegalHoldWhitelistedTeams :: PrepQuery R () (Identity TeamId)
-selectLegalHoldWhitelistedTeams =
-  [r|
-        select team from legalhold_whitelisted
-    |]
-
 selectLegalHoldWhitelistedTeam :: PrepQuery R (Identity TeamId) (Identity TeamId)
 selectLegalHoldWhitelistedTeam =
   [r|

services/galley/src/Galley/Run.hs

@@ -21,12 +21,11 @@ module Galley.Run
   )
 where
 
-import Cassandra (ClientState, runClient, shutdown)
+import Cassandra (runClient, shutdown)
 import Cassandra.Schema (versionCheck)
 import qualified Control.Concurrent.Async as Async
 import Control.Exception (finally)
 import Control.Lens (view, (^.))
-import Data.Id (TeamId)
 import qualified Data.Metrics.Middleware as M
 import Data.Metrics.Servant (servantPlusWAIPrometheusMiddleware)
 import Data.Misc (portNumber)
@@ -37,13 +36,10 @@ import qualified Galley.API.Internal as Internal
 import Galley.App
 import qualified Galley.App as App
 import qualified Galley.Data as Data
-import Galley.Data.LegalHold (getLegalholdWhitelistedTeams)
 import Galley.Options (Opts, optGalley)
-import qualified Galley.Options as Opts
 import qualified Galley.Queue as Q
-import qualified Galley.Types.Teams as Teams
 import Imports
-import Network.Wai (Application, Middleware)
+import Network.Wai (Application)
 import qualified Network.Wai.Middleware.Gunzip as GZip
 import qualified Network.Wai.Middleware.Gzip as GZip
 import Network.Wai.Utilities.Server
@@ -79,7 +75,7 @@ run o = do
 mkApp :: Opts -> IO (Application, Env, IO ())
 mkApp o = do
   m <- M.metrics
-  e <- App.createEnv mkLegalholdWhitelist m o
+  e <- App.createEnv m o
   let l = e ^. App.applog
   runClient (e ^. cstate) $
     versionCheck Data.schemaVersion
@@ -92,7 +88,6 @@ mkApp o = do
           . catchErrors l [Right m]
           . GZip.gunzip
           . GZip.gzip GZip.def
-          . refreshLegalholdWhitelist e
   return (middlewares $ servantApp e, e, finalizer)
   where
     rtree = compile API.sitemap
@@ -118,18 +113,3 @@ refreshMetrics = do
     n <- Q.len q
     M.gaugeSet (fromIntegral n) (M.path "galley.deletequeue.len") m
     threadDelay 1000000
-
-mkLegalholdWhitelist :: ClientState -> Opts -> IO (Maybe [TeamId])
-mkLegalholdWhitelist cass opts = do
-  case opts ^. Opts.optSettings . Opts.setFeatureFlags . Teams.flagLegalHold of
-    Teams.FeatureLegalHoldDisabledPermanently -> pure Nothing
-    Teams.FeatureLegalHoldDisabledByDefault -> pure Nothing
-    Teams.FeatureLegalHoldWhitelistTeamsAndImplicitConsent -> Just <$> runClient cass getLegalholdWhitelistedTeams
-
--- | FUTUREWORK: if this is taking too much server load, we can run it probabilistically
--- (@whenM ((== 1) <$> randomRIO (1, 10)) ...@).
-refreshLegalholdWhitelist :: Env -> Middleware
-refreshLegalholdWhitelist env app req cont = do
-  mbWhitelist <- mkLegalholdWhitelist (env ^. cstate) (env ^. options)
-  atomicModifyIORef' (env ^. legalholdWhitelist) (\_ -> (mbWhitelist, ()))
-  app req cont