Wpb 5388 backend restrict contact search results according to team federation policy

libs/wire-api/src/Wire/API/Routes/FederationDomainConfig.hs

@@ -54,7 +54,7 @@ instance ToSchema FederationRestriction where
 -- information for search policy.
 data FederationDomainConfig = FederationDomainConfig
   { domain :: Domain,
-    cfgSearchPolicy :: FederatedUserSearchPolicy,
+    searchPolicy :: FederatedUserSearchPolicy,
     restriction :: FederationRestriction
   }
   deriving (Eq, Ord, Show, Generic)
@@ -66,7 +66,7 @@ instance ToSchema FederationDomainConfig where
     object "FederationDomainConfig" $
       FederationDomainConfig
         <$> domain .= field "domain" schema
-        <*> cfgSearchPolicy .= field "search_policy" schema
+        <*> searchPolicy .= field "search_policy" schema
         <*> restriction .= field "restriction" schema
 
 data FederationDomainConfigs = FederationDomainConfigs

services/brig/brig.cabal

@@ -110,7 +110,6 @@ library
     Brig.Data.Activation
     Brig.Data.Client
     Brig.Data.Connection
-    Brig.Data.Federation
     Brig.Data.Instances
     Brig.Data.LoginCode
     Brig.Data.MLS.KeyPackage
@@ -126,6 +125,8 @@ library
     Brig.Effects.CodeStore
     Brig.Effects.CodeStore.Cassandra
     Brig.Effects.Delay
+    Brig.Effects.FederationConfigStore
+    Brig.Effects.FederationConfigStore.Cassandra
     Brig.Effects.GalleyProvider
     Brig.Effects.GalleyProvider.RPC
     Brig.Effects.JwtTools

services/brig/src/Brig/API/Federation.hs

@@ -244,4 +244,4 @@ lookupSearchPolicy :: Domain -> (Handler r) FederatedUserSearchPolicy
 lookupSearchPolicy domain = do
   domainConfigs <- getFederationRemotes
   let mConfig = find ((== domain) . FD.domain) (domainConfigs.remotes)
-  pure $ maybe NoSearch FD.cfgSearchPolicy mConfig
+  pure $ maybe NoSearch FD.searchPolicy mConfig

services/brig/src/Brig/API/Internal.hs

@@ -38,7 +38,6 @@ import Brig.Code qualified as Code
 import Brig.Data.Activation
 import Brig.Data.Client qualified as Data
 import Brig.Data.Connection qualified as Data
-import Brig.Data.Federation qualified as Data
 import Brig.Data.MLS.KeyPackage qualified as Data
 import Brig.Data.User qualified as Data
 import Brig.Effects.BlacklistPhonePrefixStore (BlacklistPhonePrefixStore)

services/brig/src/Brig/Effects/FederationConfigStore.hs

@@ -0,0 +1,29 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module Brig.Effects.FederationConfigStore where
+
+import Data.Domain
+import Data.Id
+import Imports
+import Polysemy
+import Wire.API.Routes.FederationDomainConfig qualified as API
+import Wire.API.User.Search (FederatedUserSearchPolicy)
+
+data FederationRestriction = FederationRestrictionAllowAll | FederationRestrictionByTeam [TeamId]
+  deriving (Eq, Show, Ord)
+
+data FederationDomainConfig = FederationDomainConfig
+  { domain :: Domain,
+    searchPolicy :: FederatedUserSearchPolicy,
+    restriction :: FederationRestriction
+  }
+
+data FederationConfigStore m a where
+  GetFederationConfig :: Domain -> FederationConfigStore m FederationDomainConfig
+  GetFederationConfigs :: FederationConfigStore m [FederationDomainConfig]
+  AddFederationConfig :: API.FederationDomainConfig -> FederationConfigStore m ()
+  UpdateFederationConfig :: API.FederationDomainConfig -> FederationConfigStore m Bool
+  AddFederationRemoteTeam :: Domain -> TeamId -> FederationConfigStore m ()
+  RemoveFederationRemoteTeam :: Domain -> TeamId -> FederationConfigStore m ()
+
+makeSem ''FederationConfigStore

services/brig/src/Brig/Data/Federation.hs → services/brig/src/Brig/Effects/FederationConfigStore/Cassandra.hs

@@ -15,86 +15,98 @@
 -- You should have received a copy of the GNU Affero General Public License along
 -- with this program. If not, see <https://www.gnu.org/licenses/>.
 
-module Brig.Data.Federation
-  ( getFederationRemotes,
-    addFederationRemote,
-    updateFederationRemote,
-    deleteFederationRemote,
-    addFederationRemoteTeam,
-    getFederationRemoteTeams,
-    deleteFederationRemoteTeam,
+module Brig.Effects.FederationConfigStore.Cassandra
+  ( interpretFederationDomainConfig,
     AddFederationRemoteResult (..),
   )
 where
 
 import Brig.Data.Instances ()
+import Brig.Effects.FederationConfigStore
 import Cassandra
 import Control.Exception (ErrorCall (ErrorCall))
 import Control.Monad.Catch (throwM)
 import Data.Domain
 import Data.Id
 import Database.CQL.Protocol (SerialConsistency (LocalSerialConsistency), serialConsistency)
 import Imports
-import Wire.API.Routes.FederationDomainConfig
+import Polysemy
+import Wire.API.Routes.FederationDomainConfig qualified as API
 import Wire.API.User.Search
 
+interpretFederationDomainConfig :: forall m r a. (MonadClient m, Member (Embed m) r) => Sem (FederationConfigStore ': r) a -> Sem r a
+interpretFederationDomainConfig =
+  interpret $
+    embed @m . \case
+      GetFederationConfig _ -> undefined
+      GetFederationConfigs -> getFederationConfigs'
+      AddFederationConfig _ -> pure ()
+      UpdateFederationConfig _ -> pure False
+      AddFederationRemoteTeam _ _ -> pure ()
+      RemoveFederationRemoteTeam _ _ -> pure ()
+
+getFederationConfigs' :: forall m. MonadClient m => m [FederationDomainConfig]
+getFederationConfigs' = do
+  _xs <- getFederationRemotes
+  pure undefined
+
 maxKnownNodes :: Int
 maxKnownNodes = 10000
 
-getFederationRemotes :: forall m. MonadClient m => m [FederationDomainConfig]
-getFederationRemotes = (\(d, p, r) -> FederationDomainConfig d p r) <$$> qry
+getFederationRemotes :: forall m. MonadClient m => m [API.FederationDomainConfig]
+getFederationRemotes = (\(d, p, r) -> API.FederationDomainConfig d p r) <$$> qry
   where
-    qry :: m [(Domain, FederatedUserSearchPolicy, FederationRestriction)]
+    qry :: m [(Domain, FederatedUserSearchPolicy, API.FederationRestriction)]
     qry = retry x1 . query get $ params LocalQuorum ()
 
-    get :: PrepQuery R () (Domain, FederatedUserSearchPolicy, FederationRestriction)
+    get :: PrepQuery R () (Domain, FederatedUserSearchPolicy, API.FederationRestriction)
     get = fromString $ "SELECT domain, search_policy, restriction FROM federation_remotes LIMIT " <> show maxKnownNodes
 
 data AddFederationRemoteResult = AddFederationRemoteSuccess | AddFederationRemoteMaxRemotesReached
 
-addFederationRemote :: MonadClient m => FederationDomainConfig -> m AddFederationRemoteResult
-addFederationRemote (FederationDomainConfig rDomain searchPolicy restriction) = do
+_addFederationRemote :: MonadClient m => API.FederationDomainConfig -> m AddFederationRemoteResult
+_addFederationRemote (API.FederationDomainConfig rDomain searchPolicy restriction) = do
   l <- length <$> getFederationRemotes
   if l >= maxKnownNodes
     then pure AddFederationRemoteMaxRemotesReached
     else AddFederationRemoteSuccess <$ retry x5 (write add (params LocalQuorum (rDomain, searchPolicy, restriction)))
   where
-    add :: PrepQuery W (Domain, FederatedUserSearchPolicy, FederationRestriction) ()
+    add :: PrepQuery W (Domain, FederatedUserSearchPolicy, API.FederationRestriction) ()
     add = "INSERT INTO federation_remotes (domain, search_policy, restriction) VALUES (?, ?, ?)"
 
-updateFederationRemote :: MonadClient m => FederationDomainConfig -> m Bool
-updateFederationRemote (FederationDomainConfig rDomain searchPolicy restriction) = do
+_updateFederationRemote :: MonadClient m => API.FederationDomainConfig -> m Bool
+_updateFederationRemote (API.FederationDomainConfig rDomain searchPolicy restriction) = do
   retry x1 (trans upd (params LocalQuorum (searchPolicy, restriction, rDomain)) {serialConsistency = Just LocalSerialConsistency}) >>= \case
     [] -> pure False
     [_] -> pure True
     _ -> throwM $ ErrorCall "Primary key violation detected federation_remotes"
   where
-    upd :: PrepQuery W (FederatedUserSearchPolicy, FederationRestriction, Domain) x
+    upd :: PrepQuery W (FederatedUserSearchPolicy, API.FederationRestriction, Domain) x
     upd = "UPDATE federation_remotes SET search_policy = ?, restriction = ? WHERE domain = ? IF EXISTS"
 
-deleteFederationRemote :: MonadClient m => Domain -> m ()
-deleteFederationRemote rDomain =
+_deleteFederationRemote :: MonadClient m => Domain -> m ()
+_deleteFederationRemote rDomain =
   retry x1 $ write delete (params LocalQuorum (Identity rDomain))
   where
     delete :: PrepQuery W (Identity Domain) ()
     delete = "DELETE FROM federation_remotes WHERE domain = ?"
 
-addFederationRemoteTeam :: MonadClient m => Domain -> FederationRemoteTeam -> m ()
-addFederationRemoteTeam rDomain rteam =
+_addFederationRemoteTeam :: MonadClient m => Domain -> API.FederationRemoteTeam -> m ()
+_addFederationRemoteTeam rDomain rteam =
   retry x1 $ write add (params LocalQuorum (rDomain, rteam.teamId))
   where
     add :: PrepQuery W (Domain, TeamId) ()
     add = "INSERT INTO federation_remote_teams (domain, team) VALUES (?, ?)"
 
-getFederationRemoteTeams :: MonadClient m => Domain -> m [FederationRemoteTeam]
-getFederationRemoteTeams rDomain = do
-  fmap (FederationRemoteTeam . runIdentity) <$> retry x1 (query get (params LocalQuorum (Identity rDomain)))
+_getFederationRemoteTeams :: MonadClient m => Domain -> m [API.FederationRemoteTeam]
+_getFederationRemoteTeams rDomain = do
+  fmap (API.FederationRemoteTeam . runIdentity) <$> retry x1 (query get (params LocalQuorum (Identity rDomain)))
   where
     get :: PrepQuery R (Identity Domain) (Identity TeamId)
     get = "SELECT team FROM federation_remote_teams WHERE domain = ?"
 
-deleteFederationRemoteTeam :: MonadClient m => Domain -> TeamId -> m ()
-deleteFederationRemoteTeam rDomain rteam =
+_deleteFederationRemoteTeam :: MonadClient m => Domain -> TeamId -> m ()
+_deleteFederationRemoteTeam rDomain rteam =
   retry x1 $ write delete (params LocalQuorum (rDomain, rteam))
   where
     delete :: PrepQuery W (Domain, TeamId) ()