-- This file is part of the Wire Server implementation.
--
-- Copyright (C) 2022 Wire Swiss GmbH <opensource@wire.com>
--
-- 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 <https://www.gnu.org/licenses/>.

module Wire.FederationConfigStore.Cassandra
  ( interpretFederationDomainConfig,
    remotesMapFromCfgFile,
    AddFederationRemoteResult (..),
  )
where

import Cassandra
import Control.Exception (ErrorCall (ErrorCall))
import Control.Lens
import Control.Monad.Catch (throwM)
import Data.Domain
import Data.Id
import Data.Map qualified as Map
import Data.Qualified
import Database.CQL.Protocol (SerialConsistency (LocalSerialConsistency), serialConsistency)
import Imports
import Polysemy
import Polysemy.Embed
import Wire.API.Routes.FederationDomainConfig
import Wire.API.User.Search
import Wire.FederationConfigStore

-- | Interpreter for getting the federation config from the database and the config file.
-- The config file is injected into the interpreter and has precedence over the database.
-- The config file is static and can only be changed by restarting the service.
-- If a domain is configured in the config file, it is not allowed to add it to the database.
-- If a domain is configured in the config file, it is not allowed to update it in the database.
-- If a domain is configured in the config file, it is not allowed to add a team restriction to it in the database.
-- In the future the config file will be removed and the database will be the only source of truth.
interpretFederationDomainConfig ::
  forall r a.
  ( Member (Embed IO) r
  ) =>
  ClientState ->
  Maybe FederationStrategy ->
  Map Domain FederationDomainConfig ->
  Sem (FederationConfigStore ': r) a ->
  Sem r a
interpretFederationDomainConfig :: forall (r :: EffectRow) a.
Member (Embed IO) r =>
ClientState
-> Maybe FederationStrategy
-> Map Domain FederationDomainConfig
-> Sem (FederationConfigStore : r) a
-> Sem r a
interpretFederationDomainConfig ClientState
casClient Maybe FederationStrategy
mFedStrategy Map Domain FederationDomainConfig
fedCfgs =
  (forall (rInitial :: EffectRow) x.
 FederationConfigStore (Sem rInitial) x -> Sem r x)
-> Sem (FederationConfigStore : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
FirstOrder e "interpret" =>
(forall (rInitial :: EffectRow) x. e (Sem rInitial) x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret ((forall (rInitial :: EffectRow) x.
  FederationConfigStore (Sem rInitial) x -> Sem r x)
 -> Sem (FederationConfigStore : r) a -> Sem r a)
-> (forall (rInitial :: EffectRow) x.
    FederationConfigStore (Sem rInitial) x -> Sem r x)
-> Sem (FederationConfigStore : r) a
-> Sem r a
forall a b. (a -> b) -> a -> b
$
    (forall x. Client x -> IO x) -> Sem (Embed Client : r) x -> Sem r x
forall (m1 :: * -> *) (m2 :: * -> *) (r :: EffectRow) a.
Member (Embed m2) r =>
(forall x. m1 x -> m2 x) -> Sem (Embed m1 : r) a -> Sem r a
runEmbedded (ClientState -> Client x -> IO x
forall (m :: * -> *) a. MonadIO m => ClientState -> Client a -> m a
runClient ClientState
casClient) (Sem (Embed Client : r) x -> Sem r x)
-> (FederationConfigStore (Sem rInitial) x
    -> Sem (Embed Client : r) x)
-> FederationConfigStore (Sem rInitial) x
-> Sem r x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Client x -> Sem (Embed Client : r) x
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed (Client x -> Sem (Embed Client : r) x)
-> (FederationConfigStore (Sem rInitial) x -> Client x)
-> FederationConfigStore (Sem rInitial) x
-> Sem (Embed Client : r) x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
      GetFederationConfig Domain
d -> Map Domain FederationDomainConfig
-> Domain -> Client (Maybe FederationDomainConfig)
forall (m :: * -> *).
MonadClient m =>
Map Domain FederationDomainConfig
-> Domain -> m (Maybe FederationDomainConfig)
getFederationConfig' Map Domain FederationDomainConfig
fedCfgs Domain
d
      FederationConfigStore (Sem rInitial) x
GetFederationConfigs -> Maybe FederationStrategy
-> Map Domain FederationDomainConfig
-> Client FederationDomainConfigs
forall (m :: * -> *).
MonadClient m =>
Maybe FederationStrategy
-> Map Domain FederationDomainConfig -> m FederationDomainConfigs
getFederationConfigs' Maybe FederationStrategy
mFedStrategy Map Domain FederationDomainConfig
fedCfgs
      AddFederationConfig FederationDomainConfig
cnf -> Map Domain FederationDomainConfig
-> FederationDomainConfig -> Client AddFederationRemoteResult
forall (m :: * -> *).
MonadClient m =>
Map Domain FederationDomainConfig
-> FederationDomainConfig -> m AddFederationRemoteResult
addFederationConfig' Map Domain FederationDomainConfig
fedCfgs FederationDomainConfig
cnf
      UpdateFederationConfig FederationDomainConfig
cnf -> Map Domain FederationDomainConfig
-> FederationDomainConfig -> Client UpdateFederationResult
forall (m :: * -> *).
MonadClient m =>
Map Domain FederationDomainConfig
-> FederationDomainConfig -> m UpdateFederationResult
updateFederationConfig' Map Domain FederationDomainConfig
fedCfgs FederationDomainConfig
cnf
      AddFederationRemoteTeam Domain
d TeamId
t -> Map Domain FederationDomainConfig
-> Domain -> TeamId -> Client AddFederationRemoteTeamResult
forall (m :: * -> *).
MonadClient m =>
Map Domain FederationDomainConfig
-> Domain -> TeamId -> m AddFederationRemoteTeamResult
addFederationRemoteTeam' Map Domain FederationDomainConfig
fedCfgs Domain
d TeamId
t
      RemoveFederationRemoteTeam Domain
d TeamId
t -> Domain -> TeamId -> Client ()
forall (m :: * -> *). MonadClient m => Domain -> TeamId -> m ()
removeFederationRemoteTeam' Domain
d TeamId
t
      GetFederationRemoteTeams Domain
d -> Domain -> Client [FederationRemoteTeam]
forall (m :: * -> *).
MonadClient m =>
Domain -> m [FederationRemoteTeam]
getFederationRemoteTeams' Domain
d
      BackendFederatesWith Remote (Maybe TeamId)
mtid -> Remote (Maybe TeamId)
-> Map Domain FederationDomainConfig
-> Maybe FederationStrategy
-> Client Bool
forall (m :: * -> *).
MonadClient m =>
Remote (Maybe TeamId)
-> Map Domain FederationDomainConfig
-> Maybe FederationStrategy
-> m Bool
backendFederatesWithImpl Remote (Maybe TeamId)
mtid Map Domain FederationDomainConfig
fedCfgs Maybe FederationStrategy
mFedStrategy

-- | Compile config file list into a map indexed by domains.  Use this to make sure the config
-- file is consistent (ie., no two entries for the same domain).
-- This is called during initialization of the interpreter and the service will fail if the config is not consistent.
remotesMapFromCfgFile :: [FederationDomainConfig] -> Map Domain FederationDomainConfig
remotesMapFromCfgFile :: [FederationDomainConfig] -> Map Domain FederationDomainConfig
remotesMapFromCfgFile [FederationDomainConfig]
cfg =
  let dict :: [(Domain, FederationDomainConfig)]
dict = [(FederationDomainConfig
cnf.domain, FederationDomainConfig
cnf) | FederationDomainConfig
cnf <- [FederationDomainConfig]
cfg]
      merge :: b -> b -> b
merge b
c b
c' =
        if b
c b -> b -> Bool
forall a. Eq a => a -> a -> Bool
== b
c'
          then b
c
          else [Char] -> b
forall a. HasCallStack => [Char] -> a
error ([Char] -> b) -> [Char] -> b
forall a b. (a -> b) -> a -> b
$ [Char]
"error in config file: conflicting parameters on domain: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> (b, b) -> [Char]
forall a. Show a => a -> [Char]
show (b
c, b
c')
   in (FederationDomainConfig
 -> FederationDomainConfig -> FederationDomainConfig)
-> [(Domain, FederationDomainConfig)]
-> Map Domain FederationDomainConfig
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith FederationDomainConfig
-> FederationDomainConfig -> FederationDomainConfig
forall {b}. (Eq b, Show b) => b -> b -> b
merge [(Domain, FederationDomainConfig)]
dict

getFederationConfigs' ::
  forall m.
  (MonadClient m) =>
  Maybe FederationStrategy ->
  Map Domain FederationDomainConfig ->
  m FederationDomainConfigs
getFederationConfigs' :: forall (m :: * -> *).
MonadClient m =>
Maybe FederationStrategy
-> Map Domain FederationDomainConfig -> m FederationDomainConfigs
getFederationConfigs' Maybe FederationStrategy
mFedStrategy Map Domain FederationDomainConfig
cfgs = do
  -- FUTUREWORK: we should solely rely on `db` in the future for remote domains; merging
  -- remote domains from `cfg` is just for providing an easier, more robust migration path.
  -- See
  -- https://docs.wire.com/understand/federation/backend-communication.html#configuring-remote-connections,
  -- http://docs.wire.com/developer/developer/federation-design-aspects.html#configuring-remote-connections-dev-perspective
  -- (because the creation and update of a federation config is guarded, we can safely merge the two configs here)
  [FederationDomainConfig]
remotes <-
    [FederationDomainConfig]
-> [FederationDomainConfig] -> [FederationDomainConfig]
forall a. Semigroup a => a -> a -> a
(<>)
      ([FederationDomainConfig]
 -> [FederationDomainConfig] -> [FederationDomainConfig])
-> m [FederationDomainConfig]
-> m ([FederationDomainConfig] -> [FederationDomainConfig])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m [FederationDomainConfig]
forall (m :: * -> *). MonadClient m => m [FederationDomainConfig]
getFederationRemotesFromDb
      m ([FederationDomainConfig] -> [FederationDomainConfig])
-> m [FederationDomainConfig] -> m [FederationDomainConfig]
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [FederationDomainConfig] -> m [FederationDomainConfig]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map Domain FederationDomainConfig -> [FederationDomainConfig]
forall k a. Map k a -> [a]
Map.elems Map Domain FederationDomainConfig
cfgs)

  FederationDomainConfigs
defFederationDomainConfigs
    FederationDomainConfigs
-> (FederationDomainConfigs -> FederationDomainConfigs)
-> FederationDomainConfigs
forall a b. a -> (a -> b) -> b
& (FederationDomainConfigs -> FederationDomainConfigs)
-> (FederationStrategy
    -> FederationDomainConfigs -> FederationDomainConfigs)
-> Maybe FederationStrategy
-> FederationDomainConfigs
-> FederationDomainConfigs
forall b a. b -> (a -> b) -> Maybe a -> b
maybe FederationDomainConfigs -> FederationDomainConfigs
forall a. a -> a
id (\FederationStrategy
v FederationDomainConfigs
cfg -> FederationDomainConfigs
cfg {strategy = v}) Maybe FederationStrategy
mFedStrategy
    FederationDomainConfigs
-> (FederationDomainConfigs -> FederationDomainConfigs)
-> FederationDomainConfigs
forall a b. a -> (a -> b) -> b
& (\FederationDomainConfigs
cfg -> FederationDomainConfigs
cfg {remotes = remotes})
    FederationDomainConfigs
-> (FederationDomainConfigs -> m FederationDomainConfigs)
-> m FederationDomainConfigs
forall a b. a -> (a -> b) -> b
& FederationDomainConfigs -> m FederationDomainConfigs
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

maxKnownNodes :: Int
maxKnownNodes :: Int
maxKnownNodes = Int
10000

getFederationConfig' :: (MonadClient m) => Map Domain FederationDomainConfig -> Domain -> m (Maybe FederationDomainConfig)
getFederationConfig' :: forall (m :: * -> *).
MonadClient m =>
Map Domain FederationDomainConfig
-> Domain -> m (Maybe FederationDomainConfig)
getFederationConfig' Map Domain FederationDomainConfig
cfgs Domain
rDomain = case (FederationDomainConfig -> Bool)
-> Map Domain FederationDomainConfig
-> Maybe FederationDomainConfig
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Domain -> Domain -> Bool
forall a. Eq a => a -> a -> Bool
== Domain
rDomain) (Domain -> Bool)
-> (FederationDomainConfig -> Domain)
-> FederationDomainConfig
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FederationDomainConfig -> Domain
domain) Map Domain FederationDomainConfig
cfgs of
  Just FederationDomainConfig
cfg -> Maybe FederationDomainConfig -> m (Maybe FederationDomainConfig)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe FederationDomainConfig -> m (Maybe FederationDomainConfig))
-> (FederationDomainConfig -> Maybe FederationDomainConfig)
-> FederationDomainConfig
-> m (Maybe FederationDomainConfig)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FederationDomainConfig -> Maybe FederationDomainConfig
forall a. a -> Maybe a
Just (FederationDomainConfig -> m (Maybe FederationDomainConfig))
-> FederationDomainConfig -> m (Maybe FederationDomainConfig)
forall a b. (a -> b) -> a -> b
$ FederationDomainConfig
cfg -- the configuration from the file has precedence (if exists there should not be a db entry at all)
  Maybe FederationDomainConfig
Nothing -> do
    Maybe (FederatedUserSearchPolicy, Maybe Int32)
mCnf <- RetrySettings
-> m (Maybe (FederatedUserSearchPolicy, Maybe Int32))
-> m (Maybe (FederatedUserSearchPolicy, Maybe Int32))
forall (m :: * -> *) a.
MonadClient m =>
RetrySettings -> m a -> m a
retry RetrySettings
x1 (PrepQuery
  R (Identity Domain) (FederatedUserSearchPolicy, Maybe Int32)
-> QueryParams (Identity Domain)
-> m (Maybe (FederatedUserSearchPolicy, Maybe Int32))
forall (m :: * -> *) a b (q :: * -> * -> * -> *).
(MonadClient m, Tuple a, Tuple b, RunQ q) =>
q R a b -> QueryParams a -> m (Maybe b)
query1 PrepQuery
  R (Identity Domain) (FederatedUserSearchPolicy, Maybe Int32)
q (Consistency -> Identity Domain -> QueryParams (Identity Domain)
forall a. Consistency -> a -> QueryParams a
params Consistency
LocalQuorum (Domain -> Identity Domain
forall a. a -> Identity a
Identity Domain
rDomain)))
    case Maybe (FederatedUserSearchPolicy, Maybe Int32)
mCnf of
      Just (FederatedUserSearchPolicy
p, Maybe Int32
r) -> FederationDomainConfig -> Maybe FederationDomainConfig
forall a. a -> Maybe a
Just (FederationDomainConfig -> Maybe FederationDomainConfig)
-> (FederationRestriction -> FederationDomainConfig)
-> FederationRestriction
-> Maybe FederationDomainConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Domain
-> FederatedUserSearchPolicy
-> FederationRestriction
-> FederationDomainConfig
FederationDomainConfig Domain
rDomain FederatedUserSearchPolicy
p (FederationRestriction -> Maybe FederationDomainConfig)
-> m FederationRestriction -> m (Maybe FederationDomainConfig)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Domain -> Int32 -> m FederationRestriction
forall (m :: * -> *).
MonadClient m =>
Domain -> Int32 -> m FederationRestriction
toRestriction Domain
rDomain (Int32 -> Maybe Int32 -> Int32
forall a. a -> Maybe a -> a
fromMaybe Int32
0 Maybe Int32
r)
      Maybe (FederatedUserSearchPolicy, Maybe Int32)
Nothing -> Maybe FederationDomainConfig -> m (Maybe FederationDomainConfig)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe FederationDomainConfig
forall a. Maybe a
Nothing
  where
    q :: PrepQuery R (Identity Domain) (FederatedUserSearchPolicy, Maybe Int32)
    q :: PrepQuery
  R (Identity Domain) (FederatedUserSearchPolicy, Maybe Int32)
q = PrepQuery
  R (Identity Domain) (FederatedUserSearchPolicy, Maybe Int32)
"SELECT search_policy, restriction FROM federation_remotes WHERE domain = ?"

getFederationRemotesFromDb :: forall m. (MonadClient m) => m [FederationDomainConfig]
getFederationRemotesFromDb :: forall (m :: * -> *). MonadClient m => m [FederationDomainConfig]
getFederationRemotesFromDb = (\(Domain
d, FederatedUserSearchPolicy
p, FederationRestriction
r) -> Domain
-> FederatedUserSearchPolicy
-> FederationRestriction
-> FederationDomainConfig
FederationDomainConfig Domain
d FederatedUserSearchPolicy
p FederationRestriction
r) ((Domain, FederatedUserSearchPolicy, FederationRestriction)
 -> FederationDomainConfig)
-> m [(Domain, FederatedUserSearchPolicy, FederationRestriction)]
-> m [FederationDomainConfig]
forall (f :: * -> *) (g :: * -> *) a b.
(Functor f, Functor g) =>
(a -> b) -> f (g a) -> f (g b)
<$$> m [(Domain, FederatedUserSearchPolicy, FederationRestriction)]
qry
  where
    qry :: m [(Domain, FederatedUserSearchPolicy, FederationRestriction)]
    qry :: m [(Domain, FederatedUserSearchPolicy, FederationRestriction)]
qry = do
      [(Domain, FederatedUserSearchPolicy, Maybe Int32)]
res <- RetrySettings
-> m [(Domain, FederatedUserSearchPolicy, Maybe Int32)]
-> m [(Domain, FederatedUserSearchPolicy, Maybe Int32)]
forall (m :: * -> *) a.
MonadClient m =>
RetrySettings -> m a -> m a
retry RetrySettings
x1 (m [(Domain, FederatedUserSearchPolicy, Maybe Int32)]
 -> m [(Domain, FederatedUserSearchPolicy, Maybe Int32)])
-> (QueryParams ()
    -> m [(Domain, FederatedUserSearchPolicy, Maybe Int32)])
-> QueryParams ()
-> m [(Domain, FederatedUserSearchPolicy, Maybe Int32)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrepQuery R () (Domain, FederatedUserSearchPolicy, Maybe Int32)
-> QueryParams ()
-> m [(Domain, FederatedUserSearchPolicy, Maybe Int32)]
forall (m :: * -> *) a b (q :: * -> * -> * -> *).
(MonadClient m, Tuple a, Tuple b, RunQ q) =>
q R a b -> QueryParams a -> m [b]
query PrepQuery R () (Domain, FederatedUserSearchPolicy, Maybe Int32)
get (QueryParams ()
 -> m [(Domain, FederatedUserSearchPolicy, Maybe Int32)])
-> QueryParams ()
-> m [(Domain, FederatedUserSearchPolicy, Maybe Int32)]
forall a b. (a -> b) -> a -> b
$ Consistency -> () -> QueryParams ()
forall a. Consistency -> a -> QueryParams a
params Consistency
LocalQuorum ()
      [(Domain, FederatedUserSearchPolicy, Maybe Int32)]
-> ((Domain, FederatedUserSearchPolicy, Maybe Int32)
    -> m (Domain, FederatedUserSearchPolicy, FederationRestriction))
-> m [(Domain, FederatedUserSearchPolicy, FederationRestriction)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Domain, FederatedUserSearchPolicy, Maybe Int32)]
res (((Domain, FederatedUserSearchPolicy, Maybe Int32)
  -> m (Domain, FederatedUserSearchPolicy, FederationRestriction))
 -> m [(Domain, FederatedUserSearchPolicy, FederationRestriction)])
-> ((Domain, FederatedUserSearchPolicy, Maybe Int32)
    -> m (Domain, FederatedUserSearchPolicy, FederationRestriction))
-> m [(Domain, FederatedUserSearchPolicy, FederationRestriction)]
forall a b. (a -> b) -> a -> b
$ \(Domain
d, FederatedUserSearchPolicy
p, Maybe Int32
rInt) -> do
        (Domain
d,FederatedUserSearchPolicy
p,) (FederationRestriction
 -> (Domain, FederatedUserSearchPolicy, FederationRestriction))
-> m FederationRestriction
-> m (Domain, FederatedUserSearchPolicy, FederationRestriction)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Domain -> Int32 -> m FederationRestriction
forall (m :: * -> *).
MonadClient m =>
Domain -> Int32 -> m FederationRestriction
toRestriction Domain
d (Int32 -> Maybe Int32 -> Int32
forall a. a -> Maybe a -> a
fromMaybe Int32
0 Maybe Int32
rInt)

    get :: PrepQuery R () (Domain, FederatedUserSearchPolicy, Maybe Int32)
    get :: PrepQuery R () (Domain, FederatedUserSearchPolicy, Maybe Int32)
get = [Char]
-> PrepQuery R () (Domain, FederatedUserSearchPolicy, Maybe Int32)
forall a. IsString a => [Char] -> a
fromString ([Char]
 -> PrepQuery R () (Domain, FederatedUserSearchPolicy, Maybe Int32))
-> [Char]
-> PrepQuery R () (Domain, FederatedUserSearchPolicy, Maybe Int32)
forall a b. (a -> b) -> a -> b
$ [Char]
"SELECT domain, search_policy, restriction FROM federation_remotes LIMIT " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show Int
maxKnownNodes

addFederationConfig' :: (MonadClient m) => Map Domain FederationDomainConfig -> FederationDomainConfig -> m AddFederationRemoteResult
addFederationConfig' :: forall (m :: * -> *).
MonadClient m =>
Map Domain FederationDomainConfig
-> FederationDomainConfig -> m AddFederationRemoteResult
addFederationConfig' Map Domain FederationDomainConfig
cfg (FederationDomainConfig Domain
rDomain FederatedUserSearchPolicy
searchPolicy FederationRestriction
restriction) = do
  -- if a domain already exists in a config, we do not allow to add it to the database
  Bool
conflict <- FederationDomainConfig -> m Bool
forall (m :: * -> *). Monad m => FederationDomainConfig -> m Bool
domainExistsInConfig (Domain
-> FederatedUserSearchPolicy
-> FederationRestriction
-> FederationDomainConfig
FederationDomainConfig Domain
rDomain FederatedUserSearchPolicy
searchPolicy FederationRestriction
restriction)
  if Bool
conflict
    then AddFederationRemoteResult -> m AddFederationRemoteResult
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AddFederationRemoteResult -> m AddFederationRemoteResult)
-> AddFederationRemoteResult -> m AddFederationRemoteResult
forall a b. (a -> b) -> a -> b
$ Map Domain FederationDomainConfig -> AddFederationRemoteResult
AddFederationRemoteDivergingConfig Map Domain FederationDomainConfig
cfg
    else do
      Int
l <- [FederationDomainConfig] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([FederationDomainConfig] -> Int)
-> m [FederationDomainConfig] -> m Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m [FederationDomainConfig]
forall (m :: * -> *). MonadClient m => m [FederationDomainConfig]
getFederationRemotesFromDb
      if Int
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
maxKnownNodes
        then AddFederationRemoteResult -> m AddFederationRemoteResult
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AddFederationRemoteResult
AddFederationRemoteMaxRemotesReached
        else
          AddFederationRemoteResult
AddFederationRemoteSuccess AddFederationRemoteResult -> m () -> m AddFederationRemoteResult
forall a b. a -> m b -> m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ do
            RetrySettings -> m () -> m ()
forall (m :: * -> *) a.
MonadClient m =>
RetrySettings -> m a -> m a
retry RetrySettings
x5 (PrepQuery W (Domain, FederatedUserSearchPolicy, Int32) ()
-> QueryParams (Domain, FederatedUserSearchPolicy, Int32) -> m ()
forall (m :: * -> *) a (q :: * -> * -> * -> *).
(MonadClient m, Tuple a, RunQ q) =>
q W a () -> QueryParams a -> m ()
write PrepQuery W (Domain, FederatedUserSearchPolicy, Int32) ()
addConfig (Consistency
-> (Domain, FederatedUserSearchPolicy, Int32)
-> QueryParams (Domain, FederatedUserSearchPolicy, Int32)
forall a. Consistency -> a -> QueryParams a
params Consistency
LocalQuorum (Domain
rDomain, FederatedUserSearchPolicy
searchPolicy, FederationRestriction -> Int32
fromRestriction FederationRestriction
restriction)))
            case FederationRestriction
restriction of
              FederationRestrictionByTeam [TeamId]
tids ->
                RetrySettings -> m () -> m ()
forall (m :: * -> *) a.
MonadClient m =>
RetrySettings -> m a -> m a
retry RetrySettings
x5 (m () -> m ())
-> ((TeamId -> BatchM ()) -> m ()) -> (TeamId -> BatchM ()) -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BatchM () -> m ()
forall (m :: * -> *). MonadClient m => BatchM () -> m ()
batch (BatchM () -> m ())
-> ((TeamId -> BatchM ()) -> BatchM ())
-> (TeamId -> BatchM ())
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TeamId] -> (TeamId -> BatchM ()) -> BatchM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [TeamId]
tids ((TeamId -> BatchM ()) -> m ()) -> (TeamId -> BatchM ()) -> m ()
forall a b. (a -> b) -> a -> b
$ PrepQuery W (Domain, TeamId) () -> (Domain, TeamId) -> BatchM ()
forall a b.
(Show a, Tuple a, Tuple b) =>
PrepQuery W a b -> a -> BatchM ()
addPrepQuery PrepQuery W (Domain, TeamId) ()
addTeams ((Domain, TeamId) -> BatchM ())
-> (TeamId -> (Domain, TeamId)) -> TeamId -> BatchM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Domain
rDomain,)
              FederationRestriction
FederationRestrictionAllowAll -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  where
    -- If remote domain is registered in config file, the version that can be added to the
    -- database must be the same.
    domainExistsInConfig :: (Monad m) => FederationDomainConfig -> m Bool
    domainExistsInConfig :: forall (m :: * -> *). Monad m => FederationDomainConfig -> m Bool
domainExistsInConfig FederationDomainConfig
fedDomConf = do
      Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> m Bool) -> Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ case Domain
-> Map Domain FederationDomainConfig
-> Maybe FederationDomainConfig
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (FederationDomainConfig -> Domain
domain FederationDomainConfig
fedDomConf) Map Domain FederationDomainConfig
cfg of
        Maybe FederationDomainConfig
Nothing -> Bool
False
        Just FederationDomainConfig
fedDomConf' -> FederationDomainConfig
fedDomConf' FederationDomainConfig -> FederationDomainConfig -> Bool
forall a. Eq a => a -> a -> Bool
/= FederationDomainConfig
fedDomConf

    addConfig :: PrepQuery W (Domain, FederatedUserSearchPolicy, Int32) ()
    addConfig :: PrepQuery W (Domain, FederatedUserSearchPolicy, Int32) ()
addConfig = PrepQuery W (Domain, FederatedUserSearchPolicy, Int32) ()
"INSERT INTO federation_remotes (domain, search_policy, restriction) VALUES (?, ?, ?)"

    addTeams :: PrepQuery W (Domain, TeamId) ()
    addTeams :: PrepQuery W (Domain, TeamId) ()
addTeams = PrepQuery W (Domain, TeamId) ()
"INSERT INTO federation_remote_teams (domain, team) VALUES (?, ?)"

updateFederationConfig' :: (MonadClient m) => Map Domain FederationDomainConfig -> FederationDomainConfig -> m UpdateFederationResult
updateFederationConfig' :: forall (m :: * -> *).
MonadClient m =>
Map Domain FederationDomainConfig
-> FederationDomainConfig -> m UpdateFederationResult
updateFederationConfig' Map Domain FederationDomainConfig
cfgs (FederationDomainConfig Domain
rDomain FederatedUserSearchPolicy
searchPolicy FederationRestriction
restriction) = do
  -- if a domain already exists in a config, we do not allow update it
  if Domain
rDomain Domain -> Map Domain Domain -> Bool
forall a. Eq a => a -> Map Domain a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (FederationDomainConfig -> Domain
domain (FederationDomainConfig -> Domain)
-> Map Domain FederationDomainConfig -> Map Domain Domain
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Domain FederationDomainConfig
cfgs)
    then UpdateFederationResult -> m UpdateFederationResult
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UpdateFederationResult
UpdateFederationRemoteDivergingConfig
    else do
      let configParams :: QueryParams (FederatedUserSearchPolicy, Int32, Domain)
configParams =
            ( Consistency
-> (FederatedUserSearchPolicy, Int32, Domain)
-> QueryParams (FederatedUserSearchPolicy, Int32, Domain)
forall a. Consistency -> a -> QueryParams a
params
                Consistency
LocalQuorum
                (FederatedUserSearchPolicy
searchPolicy, FederationRestriction -> Int32
fromRestriction FederationRestriction
restriction, Domain
rDomain)
            )
              { serialConsistency = Just LocalSerialConsistency
              }
      [Row]
r <- RetrySettings -> m [Row] -> m [Row]
forall (m :: * -> *) a.
MonadClient m =>
RetrySettings -> m a -> m a
retry RetrySettings
x1 (PrepQuery W (FederatedUserSearchPolicy, Int32, Domain) Row
-> QueryParams (FederatedUserSearchPolicy, Int32, Domain)
-> m [Row]
forall (m :: * -> *) a (q :: * -> * -> * -> *).
(MonadClient m, Tuple a, RunQ q) =>
q W a Row -> QueryParams a -> m [Row]
trans PrepQuery W (FederatedUserSearchPolicy, Int32, Domain) Row
forall x. PrepQuery W (FederatedUserSearchPolicy, Int32, Domain) x
updateConfig QueryParams (FederatedUserSearchPolicy, Int32, Domain)
configParams)
      m ()
forall (m :: * -> *). MonadClient m => m ()
updateTeams
      case [Row]
r of
        [] -> UpdateFederationResult -> m UpdateFederationResult
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UpdateFederationResult
UpdateFederationRemoteNotFound
        [Row
_] -> UpdateFederationResult -> m UpdateFederationResult
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UpdateFederationResult
UpdateFederationSuccess
        [Row]
_ -> ErrorCall -> m UpdateFederationResult
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (ErrorCall -> m UpdateFederationResult)
-> ErrorCall -> m UpdateFederationResult
forall a b. (a -> b) -> a -> b
$ [Char] -> ErrorCall
ErrorCall [Char]
"Primary key violation detected federation_remotes"
  where
    updateConfig :: PrepQuery W (FederatedUserSearchPolicy, Int32, Domain) x
    updateConfig :: forall x. PrepQuery W (FederatedUserSearchPolicy, Int32, Domain) x
updateConfig = PrepQuery W (FederatedUserSearchPolicy, Int32, Domain) x
"UPDATE federation_remotes SET search_policy = ?, restriction = ? WHERE domain = ? IF EXISTS"

    updateTeams :: (MonadClient m) => m ()
    updateTeams :: forall (m :: * -> *). MonadClient m => m ()
updateTeams = RetrySettings -> m () -> m ()
forall (m :: * -> *) a.
MonadClient m =>
RetrySettings -> m a -> m a
retry RetrySettings
x5 (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      PrepQuery W (Identity Domain) ()
-> QueryParams (Identity Domain) -> m ()
forall (m :: * -> *) a (q :: * -> * -> * -> *).
(MonadClient m, Tuple a, RunQ q) =>
q W a () -> QueryParams a -> m ()
write PrepQuery W (Identity Domain) ()
dropTeams (Consistency -> Identity Domain -> QueryParams (Identity Domain)
forall a. Consistency -> a -> QueryParams a
params Consistency
LocalQuorum (Domain -> Identity Domain
forall a. a -> Identity a
Identity Domain
rDomain))
      case FederationRestriction
restriction of
        FederationRestrictionByTeam [TeamId]
tids ->
          BatchM () -> m ()
forall (m :: * -> *). MonadClient m => BatchM () -> m ()
batch (BatchM () -> m ())
-> ((TeamId -> BatchM ()) -> BatchM ())
-> (TeamId -> BatchM ())
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TeamId] -> (TeamId -> BatchM ()) -> BatchM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [TeamId]
tids ((TeamId -> BatchM ()) -> m ()) -> (TeamId -> BatchM ()) -> m ()
forall a b. (a -> b) -> a -> b
$ PrepQuery W (Domain, TeamId) () -> (Domain, TeamId) -> BatchM ()
forall a b.
(Show a, Tuple a, Tuple b) =>
PrepQuery W a b -> a -> BatchM ()
addPrepQuery PrepQuery W (Domain, TeamId) ()
insertTeam ((Domain, TeamId) -> BatchM ())
-> (TeamId -> (Domain, TeamId)) -> TeamId -> BatchM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Domain
rDomain,)
        FederationRestriction
FederationRestrictionAllowAll -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

    dropTeams :: PrepQuery W (Identity Domain) ()
    dropTeams :: PrepQuery W (Identity Domain) ()
dropTeams = PrepQuery W (Identity Domain) ()
"DELETE FROM federation_remote_teams WHERE domain = ?"

    insertTeam :: PrepQuery W (Domain, TeamId) ()
    insertTeam :: PrepQuery W (Domain, TeamId) ()
insertTeam = PrepQuery W (Domain, TeamId) ()
"INSERT INTO federation_remote_teams (domain, team) VALUES (?, ?)"

addFederationRemoteTeam' :: (MonadClient m) => Map Domain FederationDomainConfig -> Domain -> TeamId -> m AddFederationRemoteTeamResult
addFederationRemoteTeam' :: forall (m :: * -> *).
MonadClient m =>
Map Domain FederationDomainConfig
-> Domain -> TeamId -> m AddFederationRemoteTeamResult
addFederationRemoteTeam' Map Domain FederationDomainConfig
cfgs Domain
rDomain TeamId
tid = do
  Maybe FederationDomainConfig
mDom <- Map Domain FederationDomainConfig
-> Domain -> m (Maybe FederationDomainConfig)
forall (m :: * -> *).
MonadClient m =>
Map Domain FederationDomainConfig
-> Domain -> m (Maybe FederationDomainConfig)
getFederationConfig' Map Domain FederationDomainConfig
cfgs Domain
rDomain
  case Maybe FederationDomainConfig
mDom of
    Maybe FederationDomainConfig
Nothing ->
      AddFederationRemoteTeamResult -> m AddFederationRemoteTeamResult
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AddFederationRemoteTeamResult
AddFederationRemoteTeamDomainNotFound
    Just (FederationDomainConfig Domain
_ FederatedUserSearchPolicy
_ FederationRestriction
FederationRestrictionAllowAll) ->
      AddFederationRemoteTeamResult -> m AddFederationRemoteTeamResult
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AddFederationRemoteTeamResult
AddFederationRemoteTeamRestrictionAllowAll
    Just FederationDomainConfig
_ -> do
      RetrySettings -> m () -> m ()
forall (m :: * -> *) a.
MonadClient m =>
RetrySettings -> m a -> m a
retry RetrySettings
x1 (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ PrepQuery W (Domain, TeamId) ()
-> QueryParams (Domain, TeamId) -> m ()
forall (m :: * -> *) a (q :: * -> * -> * -> *).
(MonadClient m, Tuple a, RunQ q) =>
q W a () -> QueryParams a -> m ()
write PrepQuery W (Domain, TeamId) ()
add (Consistency -> (Domain, TeamId) -> QueryParams (Domain, TeamId)
forall a. Consistency -> a -> QueryParams a
params Consistency
LocalQuorum (Domain
rDomain, TeamId
tid))
      AddFederationRemoteTeamResult -> m AddFederationRemoteTeamResult
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AddFederationRemoteTeamResult
AddFederationRemoteTeamSuccess
  where
    add :: PrepQuery W (Domain, TeamId) ()
    add :: PrepQuery W (Domain, TeamId) ()
add = PrepQuery W (Domain, TeamId) ()
"INSERT INTO federation_remote_teams (domain, team) VALUES (?, ?)"

getFederationRemoteTeams' :: (MonadClient m) => Domain -> m [FederationRemoteTeam]
getFederationRemoteTeams' :: forall (m :: * -> *).
MonadClient m =>
Domain -> m [FederationRemoteTeam]
getFederationRemoteTeams' Domain
rDomain = do
  (Identity TeamId -> FederationRemoteTeam)
-> [Identity TeamId] -> [FederationRemoteTeam]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TeamId -> FederationRemoteTeam
FederationRemoteTeam (TeamId -> FederationRemoteTeam)
-> (Identity TeamId -> TeamId)
-> Identity TeamId
-> FederationRemoteTeam
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity TeamId -> TeamId
forall a. Identity a -> a
runIdentity) ([Identity TeamId] -> [FederationRemoteTeam])
-> m [Identity TeamId] -> m [FederationRemoteTeam]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RetrySettings -> m [Identity TeamId] -> m [Identity TeamId]
forall (m :: * -> *) a.
MonadClient m =>
RetrySettings -> m a -> m a
retry RetrySettings
x1 (PrepQuery R (Identity Domain) (Identity TeamId)
-> QueryParams (Identity Domain) -> m [Identity TeamId]
forall (m :: * -> *) a b (q :: * -> * -> * -> *).
(MonadClient m, Tuple a, Tuple b, RunQ q) =>
q R a b -> QueryParams a -> m [b]
query PrepQuery R (Identity Domain) (Identity TeamId)
get (Consistency -> Identity Domain -> QueryParams (Identity Domain)
forall a. Consistency -> a -> QueryParams a
params Consistency
LocalQuorum (Domain -> Identity Domain
forall a. a -> Identity a
Identity Domain
rDomain)))
  where
    get :: PrepQuery R (Identity Domain) (Identity TeamId)
    get :: PrepQuery R (Identity Domain) (Identity TeamId)
get = PrepQuery R (Identity Domain) (Identity TeamId)
"SELECT team FROM federation_remote_teams WHERE domain = ?"

removeFederationRemoteTeam' :: (MonadClient m) => Domain -> TeamId -> m ()
removeFederationRemoteTeam' :: forall (m :: * -> *). MonadClient m => Domain -> TeamId -> m ()
removeFederationRemoteTeam' Domain
rDomain TeamId
rteam =
  RetrySettings -> m () -> m ()
forall (m :: * -> *) a.
MonadClient m =>
RetrySettings -> m a -> m a
retry RetrySettings
x1 (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ PrepQuery W (Domain, TeamId) ()
-> QueryParams (Domain, TeamId) -> m ()
forall (m :: * -> *) a (q :: * -> * -> * -> *).
(MonadClient m, Tuple a, RunQ q) =>
q W a () -> QueryParams a -> m ()
write PrepQuery W (Domain, TeamId) ()
delete (Consistency -> (Domain, TeamId) -> QueryParams (Domain, TeamId)
forall a. Consistency -> a -> QueryParams a
params Consistency
LocalQuorum (Domain
rDomain, TeamId
rteam))
  where
    delete :: PrepQuery W (Domain, TeamId) ()
    delete :: PrepQuery W (Domain, TeamId) ()
delete = PrepQuery W (Domain, TeamId) ()
"DELETE FROM federation_remote_teams WHERE domain = ? AND team = ?"

backendFederatesWithImpl ::
  (MonadClient m) =>
  Remote (Maybe TeamId) ->
  Map Domain FederationDomainConfig ->
  Maybe FederationStrategy ->
  m Bool
backendFederatesWithImpl :: forall (m :: * -> *).
MonadClient m =>
Remote (Maybe TeamId)
-> Map Domain FederationDomainConfig
-> Maybe FederationStrategy
-> m Bool
backendFederatesWithImpl (Remote (Maybe TeamId) -> Qualified (Maybe TeamId)
forall (t :: QTag) a. QualifiedWithTag t a -> Qualified a
tUntagged -> Qualified Maybe TeamId
Nothing Domain
rDomain) Map Domain FederationDomainConfig
staticCfgs = \case
  Maybe FederationStrategy
Nothing -> Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
  Just FederationStrategy
AllowNone -> Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
  Just FederationStrategy
AllowAll -> Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  Just FederationStrategy
AllowDynamic -> do
    Map Domain FederationDomainConfig
-> Domain -> m (Maybe FederationDomainConfig)
forall (m :: * -> *).
MonadClient m =>
Map Domain FederationDomainConfig
-> Domain -> m (Maybe FederationDomainConfig)
getFederationConfig' Map Domain FederationDomainConfig
staticCfgs Domain
rDomain m (Maybe FederationDomainConfig)
-> (Maybe FederationDomainConfig -> m Bool) -> m Bool
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe FederationDomainConfig
Nothing -> Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
      Just FederationDomainConfig
c -> Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> m Bool) -> Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ FederationDomainConfig -> FederationRestriction
restriction FederationDomainConfig
c FederationRestriction -> FederationRestriction -> Bool
forall a. Eq a => a -> a -> Bool
== FederationRestriction
FederationRestrictionAllowAll
backendFederatesWithImpl (Remote (Maybe TeamId) -> Qualified (Maybe TeamId)
forall (t :: QTag) a. QualifiedWithTag t a -> Qualified a
tUntagged -> Qualified (Just TeamId
rTeam) Domain
rDomain) Map Domain FederationDomainConfig
staticCfgs = \case
  Maybe FederationStrategy
Nothing -> Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
  Just FederationStrategy
AllowNone -> Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
  Just FederationStrategy
AllowAll -> Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  Just FederationStrategy
AllowDynamic ->
    Map Domain FederationDomainConfig
-> Domain -> m (Maybe FederationDomainConfig)
forall (m :: * -> *).
MonadClient m =>
Map Domain FederationDomainConfig
-> Domain -> m (Maybe FederationDomainConfig)
getFederationConfig' Map Domain FederationDomainConfig
staticCfgs Domain
rDomain m (Maybe FederationDomainConfig)
-> (Maybe FederationDomainConfig -> m Bool) -> m Bool
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe FederationDomainConfig
Nothing -> Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
      Just (FederationDomainConfig Domain
_ FederatedUserSearchPolicy
_ FederationRestriction
FederationRestrictionAllowAll) ->
        Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
      Just (FederationDomainConfig Domain
_ FederatedUserSearchPolicy
_ (FederationRestrictionByTeam [TeamId]
ts)) -> Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> m Bool) -> Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ TeamId
rTeam TeamId -> [TeamId] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TeamId]
ts

data RestrictionException = RestrictionException Int32

instance Show RestrictionException where
  show :: RestrictionException -> [Char]
show (RestrictionException Int32
v) =
    [Char]
"Expected a RestrictionPolicy encoding, but found a value " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Int32 -> [Char]
forall a. Show a => a -> [Char]
show Int32
v

instance Exception RestrictionException

toRestriction :: (MonadClient m) => Domain -> Int32 -> m FederationRestriction
toRestriction :: forall (m :: * -> *).
MonadClient m =>
Domain -> Int32 -> m FederationRestriction
toRestriction Domain
_ Int32
0 = FederationRestriction -> m FederationRestriction
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FederationRestriction
FederationRestrictionAllowAll
toRestriction Domain
dom Int32
1 =
  ([TeamId] -> FederationRestriction)
-> m [TeamId] -> m FederationRestriction
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [TeamId] -> FederationRestriction
FederationRestrictionByTeam (m [TeamId] -> m FederationRestriction)
-> m [TeamId] -> m FederationRestriction
forall a b. (a -> b) -> a -> b
$
    Identity TeamId -> TeamId
forall a. Identity a -> a
runIdentity (Identity TeamId -> TeamId) -> m [Identity TeamId] -> m [TeamId]
forall (f :: * -> *) (g :: * -> *) a b.
(Functor f, Functor g) =>
(a -> b) -> f (g a) -> f (g b)
<$$> RetrySettings -> m [Identity TeamId] -> m [Identity TeamId]
forall (m :: * -> *) a.
MonadClient m =>
RetrySettings -> m a -> m a
retry RetrySettings
x1 (PrepQuery R (Identity Domain) (Identity TeamId)
-> QueryParams (Identity Domain) -> m [Identity TeamId]
forall (m :: * -> *) a b (q :: * -> * -> * -> *).
(MonadClient m, Tuple a, Tuple b, RunQ q) =>
q R a b -> QueryParams a -> m [b]
query PrepQuery R (Identity Domain) (Identity TeamId)
getTeams (Consistency -> Identity Domain -> QueryParams (Identity Domain)
forall a. Consistency -> a -> QueryParams a
params Consistency
LocalQuorum (Domain -> Identity Domain
forall a. a -> Identity a
Identity Domain
dom)))
  where
    getTeams :: PrepQuery R (Identity Domain) (Identity TeamId)
    getTeams :: PrepQuery R (Identity Domain) (Identity TeamId)
getTeams = [Char] -> PrepQuery R (Identity Domain) (Identity TeamId)
forall a. IsString a => [Char] -> a
fromString ([Char] -> PrepQuery R (Identity Domain) (Identity TeamId))
-> [Char] -> PrepQuery R (Identity Domain) (Identity TeamId)
forall a b. (a -> b) -> a -> b
$ [Char]
"SELECT team FROM federation_remote_teams WHERE domain = ?"
toRestriction Domain
_ Int32
v = RestrictionException -> m FederationRestriction
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (RestrictionException -> m FederationRestriction)
-> (Int32 -> RestrictionException)
-> Int32
-> m FederationRestriction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int32 -> RestrictionException
RestrictionException (Int32 -> m FederationRestriction)
-> Int32 -> m FederationRestriction
forall a b. (a -> b) -> a -> b
$ Int32
v

fromRestriction :: FederationRestriction -> Int32
fromRestriction :: FederationRestriction -> Int32
fromRestriction FederationRestriction
FederationRestrictionAllowAll = Int32
0
fromRestriction (FederationRestrictionByTeam [TeamId]
_) = Int32
1