From 452c4de99c61a6b6d26ee68052ed453f83734e0d Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Mon, 15 Nov 2021 17:18:21 -0800 Subject: [PATCH 01/28] Spar Polysemy: Split VerdictFormatStore from AReqIdStore (#1925) * Split out VerdictFormatStore effect Also did some related cleanup around orphan instances * make format * changelog * Cleanup imports Co-authored-by: Matthias Fischmann --- changelog.d/5-internal/split-eff2 | 1 + services/spar/spar.cabal | 4 +++- services/spar/src/Spar/API.hs | 9 +++++++-- services/spar/src/Spar/App.hs | 6 ++++-- services/spar/src/Spar/CanonicalInterpreter.hs | 4 ++++ services/spar/src/Spar/Sem/AReqIDStore.hs | 5 +---- .../spar/src/Spar/Sem/AReqIDStore/Cassandra.hs | 14 +++++--------- .../spar/src/Spar/Sem/AssIDStore/Cassandra.hs | 9 +++++---- .../src/Spar/Sem/BindCookieStore/Cassandra.hs | 10 +++++----- services/spar/src/Spar/Sem/VerdictFormatStore.hs | 12 ++++++++++++ .../src/Spar/Sem/VerdictFormatStore/Cassandra.hs | 16 ++++++++++++++++ .../spar/test-integration/Test/Spar/DataSpec.hs | 15 ++++++++------- 12 files changed, 71 insertions(+), 34 deletions(-) create mode 100644 changelog.d/5-internal/split-eff2 create mode 100644 services/spar/src/Spar/Sem/VerdictFormatStore.hs create mode 100644 services/spar/src/Spar/Sem/VerdictFormatStore/Cassandra.hs diff --git a/changelog.d/5-internal/split-eff2 b/changelog.d/5-internal/split-eff2 new file mode 100644 index 00000000000..1ecf1d90eac --- /dev/null +++ b/changelog.d/5-internal/split-eff2 @@ -0,0 +1 @@ +Separate VerdictFormatStore effect from AReqIdStore effect diff --git a/services/spar/spar.cabal b/services/spar/spar.cabal index c4689e5a70a..f38adbaceea 100644 --- a/services/spar/spar.cabal +++ b/services/spar/spar.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 6007f4f8ec59cf0a438cd7831dc87bda6d60acd7865f6c251bd6f2da5617b381 +-- hash: f787f064cceffbeeef6ac5c1ca7475e519a51afc3fdd173bf7a7a86a9016b238 name: spar version: 0.1 @@ -74,6 +74,8 @@ library Spar.Sem.ScimTokenStore.Cassandra Spar.Sem.ScimUserTimesStore Spar.Sem.ScimUserTimesStore.Cassandra + Spar.Sem.VerdictFormatStore + Spar.Sem.VerdictFormatStore.Cassandra other-modules: Paths_spar hs-source-dirs: diff --git a/services/spar/src/Spar/API.hs b/services/spar/src/Spar/API.hs index 39316cf97cc..935e386a276 100644 --- a/services/spar/src/Spar/API.hs +++ b/services/spar/src/Spar/API.hs @@ -67,7 +67,6 @@ import qualified Spar.Intra.BrigApp as Brig import Spar.Orphans () import Spar.Scim import Spar.Sem.AReqIDStore (AReqIDStore) -import qualified Spar.Sem.AReqIDStore as AReqIDStore import Spar.Sem.AssIDStore (AssIDStore) import Spar.Sem.BindCookieStore (BindCookieStore) import qualified Spar.Sem.BindCookieStore as BindCookieStore @@ -96,6 +95,8 @@ import Spar.Sem.ScimExternalIdStore (ScimExternalIdStore) import Spar.Sem.ScimTokenStore (ScimTokenStore) import qualified Spar.Sem.ScimTokenStore as ScimTokenStore import Spar.Sem.ScimUserTimesStore (ScimUserTimesStore) +import Spar.Sem.VerdictFormatStore (VerdictFormatStore) +import qualified Spar.Sem.VerdictFormatStore as VerdictFormatStore import System.Logger (Msg) import qualified URI.ByteString as URI import Wire.API.Cookie @@ -116,6 +117,7 @@ api :: BindCookieStore, AssIDStore, AReqIDStore, + VerdictFormatStore, ScimExternalIdStore, ScimUserTimesStore, ScimTokenStore, @@ -153,6 +155,7 @@ apiSSO :: BrigAccess, BindCookieStore, AssIDStore, + VerdictFormatStore, AReqIDStore, ScimTokenStore, DefaultSsoCode, @@ -241,6 +244,7 @@ authreq :: Logger String, BindCookieStore, AssIDStore, + VerdictFormatStore, AReqIDStore, SAML2, SamlProtocolSettings, @@ -266,7 +270,7 @@ authreq authreqttl _ zusr msucc merr idpid = do WireIdPAPIV1 -> Nothing WireIdPAPIV2 -> Just $ idp ^. SAML.idpExtraInfo . wiTeam SAML2.authReq authreqttl (SamlProtocolSettings.spIssuer mbtid) idpid - AReqIDStore.storeVerdictFormat authreqttl reqid vformat + VerdictFormatStore.store authreqttl reqid vformat cky <- initializeBindCookie zusr authreqttl Logger.log SAML.Debug $ "setting bind cookie: " <> show cky pure $ addHeader cky form @@ -324,6 +328,7 @@ authresp :: BrigAccess, BindCookieStore, AssIDStore, + VerdictFormatStore, AReqIDStore, ScimTokenStore, IdPEffect.IdP, diff --git a/services/spar/src/Spar/App.hs b/services/spar/src/Spar/App.hs index 926c466e366..eaf2285f599 100644 --- a/services/spar/src/Spar/App.hs +++ b/services/spar/src/Spar/App.hs @@ -81,7 +81,6 @@ import Spar.Error hiding (sparToServerErrorWithLogging) import qualified Spar.Intra.BrigApp as Intra import Spar.Orphans () import Spar.Sem.AReqIDStore (AReqIDStore) -import qualified Spar.Sem.AReqIDStore as AReqIDStore import Spar.Sem.BindCookieStore (BindCookieStore) import qualified Spar.Sem.BindCookieStore as BindCookieStore import Spar.Sem.BrigAccess (BrigAccess) @@ -102,6 +101,8 @@ import Spar.Sem.ScimExternalIdStore (ScimExternalIdStore) import qualified Spar.Sem.ScimExternalIdStore as ScimExternalIdStore import Spar.Sem.ScimTokenStore (ScimTokenStore) import qualified Spar.Sem.ScimTokenStore as ScimTokenStore +import Spar.Sem.VerdictFormatStore (VerdictFormatStore) +import qualified Spar.Sem.VerdictFormatStore as VerdictFormatStore import qualified System.Logger as TinyLog import URI.ByteString as URI import Web.Cookie (SetCookie, renderSetCookie) @@ -375,6 +376,7 @@ verdictHandler :: BrigAccess, BindCookieStore, AReqIDStore, + VerdictFormatStore, ScimTokenStore, IdPEffect.IdP, Error SparError, @@ -393,7 +395,7 @@ verdictHandler cky mbteam aresp verdict = do -- the InResponseTo attribute MUST match the request's ID. Logger.log SAML.Debug $ "entering verdictHandler: " <> show (fromBindCookie <$> cky, aresp, verdict) reqid <- either (throwSparSem . SparNoRequestRefInResponse . cs) pure $ SAML.rspInResponseTo aresp - format :: Maybe VerdictFormat <- AReqIDStore.getVerdictFormat reqid + format :: Maybe VerdictFormat <- VerdictFormatStore.get reqid resp <- case format of Just (VerdictFormatWeb) -> verdictHandlerResult cky mbteam verdict >>= verdictHandlerWeb diff --git a/services/spar/src/Spar/CanonicalInterpreter.hs b/services/spar/src/Spar/CanonicalInterpreter.hs index dfc245db572..5138448f570 100644 --- a/services/spar/src/Spar/CanonicalInterpreter.hs +++ b/services/spar/src/Spar/CanonicalInterpreter.hs @@ -48,6 +48,8 @@ import Spar.Sem.ScimTokenStore (ScimTokenStore) import Spar.Sem.ScimTokenStore.Cassandra (scimTokenStoreToCassandra) import Spar.Sem.ScimUserTimesStore (ScimUserTimesStore) import Spar.Sem.ScimUserTimesStore.Cassandra (scimUserTimesStoreToCassandra) +import Spar.Sem.VerdictFormatStore (VerdictFormatStore) +import Spar.Sem.VerdictFormatStore.Cassandra (verdictFormatStoreToCassandra) import qualified System.Logger as TinyLog import Wire.API.User.Saml @@ -57,6 +59,7 @@ type CanonicalEffs = BindCookieStore, AssIDStore, AReqIDStore, + VerdictFormatStore, ScimExternalIdStore, ScimUserTimesStore, ScimTokenStore, @@ -104,6 +107,7 @@ runSparToIO ctx action = . scimTokenStoreToCassandra . scimUserTimesStoreToCassandra . scimExternalIdStoreToCassandra + . verdictFormatStoreToCassandra . aReqIDStoreToCassandra . assIDStoreToCassandra . bindCookieStoreToCassandra diff --git a/services/spar/src/Spar/Sem/AReqIDStore.hs b/services/spar/src/Spar/Sem/AReqIDStore.hs index 021fc94e719..19321121960 100644 --- a/services/spar/src/Spar/Sem/AReqIDStore.hs +++ b/services/spar/src/Spar/Sem/AReqIDStore.hs @@ -1,16 +1,13 @@ module Spar.Sem.AReqIDStore where -import Data.Time (NominalDiffTime) import Imports import Polysemy import qualified SAML2.WebSSO.Types as SAML -import Wire.API.User.Saml (AReqId, VerdictFormat) +import Wire.API.User.Saml (AReqId) data AReqIDStore m a where Store :: AReqId -> SAML.Time -> AReqIDStore m () UnStore :: AReqId -> AReqIDStore m () IsAlive :: AReqId -> AReqIDStore m Bool - StoreVerdictFormat :: NominalDiffTime -> AReqId -> VerdictFormat -> AReqIDStore m () - GetVerdictFormat :: AReqId -> AReqIDStore m (Maybe VerdictFormat) makeSem ''AReqIDStore diff --git a/services/spar/src/Spar/Sem/AReqIDStore/Cassandra.hs b/services/spar/src/Spar/Sem/AReqIDStore/Cassandra.hs index bd1c0292c62..68d6c57ebf1 100644 --- a/services/spar/src/Spar/Sem/AReqIDStore/Cassandra.hs +++ b/services/spar/src/Spar/Sem/AReqIDStore/Cassandra.hs @@ -1,5 +1,3 @@ -{-# OPTIONS_GHC -Wno-orphans #-} - module Spar.Sem.AReqIDStore.Cassandra where import Cassandra @@ -8,31 +6,29 @@ import Imports hiding (MonadReader (..), Reader) import Polysemy import Polysemy.Error import Polysemy.Input (Input, input) -import SAML2.WebSSO (HasNow, fromTime, getNow) +import SAML2.WebSSO (fromTime) import qualified SAML2.WebSSO as SAML import qualified Spar.Data as Data import Spar.Error import Spar.Sem.AReqIDStore +import Spar.Sem.Now (Now) +import qualified Spar.Sem.Now as Now import Wire.API.User.Saml (Opts, TTLError) -instance Member (Embed IO) r => HasNow (Sem r) - aReqIDStoreToCassandra :: forall m r a. - (MonadClient m, Members '[Embed m, Error TTLError, Embed IO, Input Opts] r) => + (MonadClient m, Members '[Embed m, Now, Error TTLError, Embed IO, Input Opts] r) => Sem (AReqIDStore ': r) a -> Sem r a aReqIDStoreToCassandra = interpret $ \case Store itla t -> do - denv <- Data.mkEnv <$> input <*> (fromTime <$> getNow) + denv <- Data.mkEnv <$> input <*> (fromTime <$> Now.get) a <- embed @m $ runExceptT $ runReaderT (Data.storeAReqID itla t) denv case a of Left err -> throw err Right () -> pure () UnStore itla -> embed @m $ Data.unStoreAReqID itla IsAlive itla -> embed @m $ Data.isAliveAReqID itla - StoreVerdictFormat ndt itla vf -> embed @m $ Data.storeVerdictFormat ndt itla vf - GetVerdictFormat itla -> embed @m $ Data.getVerdictFormat itla ttlErrorToSparError :: Member (Error SparError) r => Sem (Error TTLError ': r) a -> Sem r a ttlErrorToSparError = mapError (SAML.CustomError . SparCassandraTTLError) diff --git a/services/spar/src/Spar/Sem/AssIDStore/Cassandra.hs b/services/spar/src/Spar/Sem/AssIDStore/Cassandra.hs index 6b42bcc8d5e..f9fff024e8a 100644 --- a/services/spar/src/Spar/Sem/AssIDStore/Cassandra.hs +++ b/services/spar/src/Spar/Sem/AssIDStore/Cassandra.hs @@ -6,21 +6,22 @@ import Imports hiding (MonadReader (..), Reader) import Polysemy import Polysemy.Error import Polysemy.Input -import SAML2.WebSSO (fromTime, getNow) +import SAML2.WebSSO (fromTime) import qualified Spar.Data as Data -import Spar.Sem.AReqIDStore.Cassandra () import Spar.Sem.AssIDStore +import Spar.Sem.Now (Now) +import qualified Spar.Sem.Now as Now import Wire.API.User.Saml (Opts, TTLError) assIDStoreToCassandra :: forall m r a. - (MonadClient m, Members '[Embed m, Error TTLError, Embed IO, Input Opts] r) => + (MonadClient m, Members '[Embed m, Now, Error TTLError, Embed IO, Input Opts] r) => Sem (AssIDStore ': r) a -> Sem r a assIDStoreToCassandra = interpret $ \case Store itla t -> do - denv <- Data.mkEnv <$> input <*> (fromTime <$> getNow) + denv <- Data.mkEnv <$> input <*> (fromTime <$> Now.get) a <- embed @m $ runExceptT $ runReaderT (Data.storeAssID itla t) denv case a of Left err -> throw err diff --git a/services/spar/src/Spar/Sem/BindCookieStore/Cassandra.hs b/services/spar/src/Spar/Sem/BindCookieStore/Cassandra.hs index 011ec4da469..6cfbb40412b 100644 --- a/services/spar/src/Spar/Sem/BindCookieStore/Cassandra.hs +++ b/services/spar/src/Spar/Sem/BindCookieStore/Cassandra.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} module Spar.Sem.BindCookieStore.Cassandra where @@ -9,20 +8,21 @@ import Imports hiding (MonadReader (..), Reader) import Polysemy import Polysemy.Error import Polysemy.Input -import SAML2.WebSSO (fromTime, getNow) +import SAML2.WebSSO (fromTime) import qualified Spar.Data as Data -import Spar.Sem.AReqIDStore.Cassandra () import Spar.Sem.BindCookieStore +import Spar.Sem.Now (Now) +import qualified Spar.Sem.Now as Now import Wire.API.User.Saml (Opts, TTLError) bindCookieStoreToCassandra :: forall m r a. - (MonadClient m, Members '[Embed m, Error TTLError, Embed IO, Input Opts] r) => + (MonadClient m, Members '[Embed m, Now, Error TTLError, Embed IO, Input Opts] r) => Sem (BindCookieStore ': r) a -> Sem r a bindCookieStoreToCassandra = interpret $ \case Insert sbc uid ndt -> do - denv <- Data.mkEnv <$> input <*> (fromTime <$> getNow) + denv <- Data.mkEnv <$> input <*> (fromTime <$> Now.get) a <- embed @m $ runExceptT $ runReaderT (Data.insertBindCookie sbc uid ndt) denv case a of Left err -> throw err diff --git a/services/spar/src/Spar/Sem/VerdictFormatStore.hs b/services/spar/src/Spar/Sem/VerdictFormatStore.hs new file mode 100644 index 00000000000..5ceb826be34 --- /dev/null +++ b/services/spar/src/Spar/Sem/VerdictFormatStore.hs @@ -0,0 +1,12 @@ +module Spar.Sem.VerdictFormatStore where + +import Data.Time (NominalDiffTime) +import Imports +import Polysemy +import Wire.API.User.Saml (AReqId, VerdictFormat) + +data VerdictFormatStore m a where + Store :: NominalDiffTime -> AReqId -> VerdictFormat -> VerdictFormatStore m () + Get :: AReqId -> VerdictFormatStore m (Maybe VerdictFormat) + +makeSem ''VerdictFormatStore diff --git a/services/spar/src/Spar/Sem/VerdictFormatStore/Cassandra.hs b/services/spar/src/Spar/Sem/VerdictFormatStore/Cassandra.hs new file mode 100644 index 00000000000..707bc2dac87 --- /dev/null +++ b/services/spar/src/Spar/Sem/VerdictFormatStore/Cassandra.hs @@ -0,0 +1,16 @@ +module Spar.Sem.VerdictFormatStore.Cassandra where + +import Cassandra +import Imports hiding (MonadReader (..), Reader) +import Polysemy +import qualified Spar.Data as Data +import Spar.Sem.VerdictFormatStore + +verdictFormatStoreToCassandra :: + forall m r a. + (MonadClient m, Member (Embed m) r) => + Sem (VerdictFormatStore ': r) a -> + Sem r a +verdictFormatStoreToCassandra = interpret $ \case + Store ndt itla vf -> embed @m $ Data.storeVerdictFormat ndt itla vf + Get itla -> embed @m $ Data.getVerdictFormat itla diff --git a/services/spar/test-integration/Test/Spar/DataSpec.hs b/services/spar/test-integration/Test/Spar/DataSpec.hs index 4bd1547b385..fb0dae7045c 100644 --- a/services/spar/test-integration/Test/Spar/DataSpec.hs +++ b/services/spar/test-integration/Test/Spar/DataSpec.hs @@ -41,6 +41,7 @@ import qualified Spar.Sem.BindCookieStore as BindCookieStore import qualified Spar.Sem.IdP as IdPEffect import qualified Spar.Sem.SAMLUserStore as SAMLUserStore import qualified Spar.Sem.ScimTokenStore as ScimTokenStore +import qualified Spar.Sem.VerdictFormatStore as VerdictFormatStore import Type.Reflection (typeRep) import URI.ByteString.QQ (uri) import Util.Core @@ -93,24 +94,24 @@ spec = do context "insert and get are \"inverses\"" $ do let check vf = it (show vf) $ do vid <- nextSAMLID - () <- runSpar $ AReqIDStore.storeVerdictFormat 1 vid vf - mvf <- runSpar $ AReqIDStore.getVerdictFormat vid + () <- runSpar $ VerdictFormatStore.store 1 vid vf + mvf <- runSpar $ VerdictFormatStore.get vid liftIO $ mvf `shouldBe` Just vf check `mapM_` [ VerdictFormatWeb, VerdictFormatMobile [uri|https://fw/ooph|] [uri|https://lu/gn|] ] context "has timed out" $ do - it "AReqIDStore.getVerdictFormat returns Nothing" $ do + it "VerdictFormatStore.get returns Nothing" $ do vid <- nextSAMLID - () <- runSpar $ AReqIDStore.storeVerdictFormat 1 vid VerdictFormatWeb + () <- runSpar $ VerdictFormatStore.store 1 vid VerdictFormatWeb liftIO $ threadDelay 2000000 - mvf <- runSpar $ AReqIDStore.getVerdictFormat vid + mvf <- runSpar $ VerdictFormatStore.get vid liftIO $ mvf `shouldBe` Nothing context "does not exist" $ do - it "AReqIDStore.getVerdictFormat returns Nothing" $ do + it "VerdictFormatStore.get returns Nothing" $ do vid <- nextSAMLID - mvf <- runSpar $ AReqIDStore.getVerdictFormat vid + mvf <- runSpar $ VerdictFormatStore.get vid liftIO $ mvf `shouldBe` Nothing describe "User" $ do context "user is new" $ do From 72a04e1a51f245b50ec61293bacd2fcf0d375bc4 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Tue, 16 Nov 2021 09:41:12 +0100 Subject: [PATCH 02/28] Remove duplicate PR numbers from changelog (#1931) --- CHANGELOG.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 5537dbb6319..e9d44bfbc00 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -32,7 +32,7 @@ * Turn placeholder access effects into actual Polysemy effects. (#1904) * Fix a bug in the IdP.Mem interpreter, and added law tests for IdP (#1863) * Introduce fine-grained error types and polysemy error effects in Galley. (#1907) -* Add polysemy store effects and split off Cassandra specific functionality from the Galley.Data module hierarchy (#1890, #1906). (#1890) +* Add polysemy store effects and split off Cassandra specific functionality from the Galley.Data module hierarchy (#1890, #1906) * Make golden-tests in wire-api package a separate test suite (for faster feedback loop during development). (#1926) * Separate IdPRawMetadataStore effect from IdP effect (#1924) * Test sending message to multiple remote domains (#1899) From bc3cf4ae446688ee81de136107e2031b2a347322 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Tue, 16 Nov 2021 14:14:46 +0100 Subject: [PATCH 03/28] Galley polysemy (5/5) - Final cleanup (#1917) * Turn legalhold requests into polysemy action * Add runFederatedConcurrentlyEither This is useful in order to handle federation errors when making multiple concurrent requests. * Introduce `runFederatedConcurrentlyEither` Also remove usage of `Galley0` in Galley.API.Query. * Unify IntraM and FederationM into an App monad Also remove Galley0 completely. * Remove HasFederatorConfig instance of Galley * Add ZAuthLocalUser combinator to Servant routes This is to extract the ZUser header as a value of type `Local UserId`. The domain is extracted from the servant context. * Turn most of the ZUser in Galley into ZLocalUser * Remove MonadReader instance of Galley * Remove MonadLogger instance of Galley * Convert Aws.enqueue to a TeamStore action * Remove (almost) all explicit uses of IO * Define Galley as a synonym for Sem * Remove uses of liftSem * Replace Galley with Sem * Remove unnecessary uses of `Input (Local ())` * Remove use of MaybeT in Action * Make galley build without polysemy-plugin * Replace ClientState Reader effect with Input * Replace all Reader effects with Input * Remove redundant constraints * Rewrite CSV streaming using Final IO --- changelog.d/5-internal/polysemy-monad | 1 + hack/bin/split-member-constraints.py | 33 + libs/wire-api/src/Wire/API/Routes/Public.hs | 111 +- .../src/Wire/API/Routes/Public/Galley.hs | 66 +- services/galley/galley.cabal | 10 +- services/galley/package.yaml | 2 - services/galley/src/Galley/API.hs | 5 +- services/galley/src/Galley/API/Action.hs | 183 ++-- services/galley/src/Galley/API/Clients.hs | 25 +- services/galley/src/Galley/API/Create.hs | 373 +++---- .../galley/src/Galley/API/CustomBackend.hs | 23 +- services/galley/src/Galley/API/Error.hs | 3 +- services/galley/src/Galley/API/Federation.hs | 130 +-- services/galley/src/Galley/API/Internal.hs | 137 +-- services/galley/src/Galley/API/LegalHold.hs | 462 +++++---- .../src/Galley/API/LegalHold/Conflicts.hs | 85 +- services/galley/src/Galley/API/Mapping.hs | 29 +- services/galley/src/Galley/API/Message.hs | 150 +-- services/galley/src/Galley/API/One2One.hs | 5 +- services/galley/src/Galley/API/Public.hs | 12 +- services/galley/src/Galley/API/Query.hs | 264 +++-- services/galley/src/Galley/API/Teams.hs | 818 ++++++++------- .../galley/src/Galley/API/Teams/Features.hs | 256 +++-- .../src/Galley/API/Teams/Notifications.hs | 29 +- services/galley/src/Galley/API/Update.hs | 945 ++++++++++-------- services/galley/src/Galley/API/Util.hs | 222 ++-- services/galley/src/Galley/App.hs | 185 +--- .../galley/src/Galley/Cassandra/Client.hs | 9 +- services/galley/src/Galley/Cassandra/Code.hs | 9 +- .../src/Galley/Cassandra/Conversation.hs | 6 +- .../Galley/Cassandra/Conversation/Members.hs | 6 +- .../src/Galley/Cassandra/ConversationList.hs | 8 +- .../src/Galley/Cassandra/CustomBackend.hs | 4 +- .../galley/src/Galley/Cassandra/LegalHold.hs | 54 +- .../src/Galley/Cassandra/SearchVisibility.hs | 4 +- .../galley/src/Galley/Cassandra/Services.hs | 4 +- services/galley/src/Galley/Cassandra/Store.hs | 6 +- services/galley/src/Galley/Cassandra/Team.hs | 21 +- .../src/Galley/Cassandra/TeamFeatures.hs | 4 +- .../src/Galley/Cassandra/TeamNotifications.hs | 23 +- services/galley/src/Galley/Effects.hs | 21 +- .../galley/src/Galley/Effects/BrigAccess.hs | 5 + .../galley/src/Galley/Effects/ClientStore.hs | 5 + .../galley/src/Galley/Effects/CodeStore.hs | 5 + .../src/Galley/Effects/FederatorAccess.hs | 9 + .../src/Galley/Effects/GundeckAccess.hs | 2 + .../src/Galley/Effects/LegalHoldStore.hs | 26 +- services/galley/src/Galley/Effects/Queue.hs | 32 + .../Galley/Effects/TeamNotificationStore.hs | 9 +- .../galley/src/Galley/Effects/TeamStore.hs | 11 + .../galley/src/Galley/Effects/WaiRoutes.hs | 38 + .../galley/src/Galley/Effects/WaiRoutes/IO.hs | 39 + services/galley/src/Galley/External.hs | 26 +- .../src/Galley/External/LegalHoldService.hs | 124 +-- .../External/LegalHoldService/Internal.hs | 99 ++ services/galley/src/Galley/Intra/Client.hs | 25 +- services/galley/src/Galley/Intra/Effects.hs | 55 +- services/galley/src/Galley/Intra/Federator.hs | 41 +- .../src/Galley/Intra/Federator/Types.hs | 36 +- services/galley/src/Galley/Intra/Journal.hs | 88 +- .../galley/src/Galley/Intra/Push/Internal.hs | 23 +- services/galley/src/Galley/Intra/Spar.hs | 3 +- services/galley/src/Galley/Intra/Team.hs | 3 +- services/galley/src/Galley/Intra/User.hs | 59 +- services/galley/src/Galley/Intra/Util.hs | 48 +- services/galley/src/Galley/Monad.hs | 82 ++ services/galley/src/Galley/Queue.hs | 12 + services/galley/src/Galley/Run.hs | 53 +- services/galley/test/integration/API.hs | 4 +- services/galley/test/integration/API/Teams.hs | 2 +- .../test/integration/API/Teams/LegalHold.hs | 4 +- .../API/Teams/LegalHold/DisabledByDefault.hs | 4 +- services/galley/test/integration/API/Util.hs | 2 +- 73 files changed, 3121 insertions(+), 2596 deletions(-) create mode 100644 changelog.d/5-internal/polysemy-monad create mode 100644 hack/bin/split-member-constraints.py create mode 100644 services/galley/src/Galley/Effects/Queue.hs create mode 100644 services/galley/src/Galley/Effects/WaiRoutes.hs create mode 100644 services/galley/src/Galley/Effects/WaiRoutes/IO.hs create mode 100644 services/galley/src/Galley/External/LegalHoldService/Internal.hs create mode 100644 services/galley/src/Galley/Monad.hs diff --git a/changelog.d/5-internal/polysemy-monad b/changelog.d/5-internal/polysemy-monad new file mode 100644 index 00000000000..eb00757ba05 --- /dev/null +++ b/changelog.d/5-internal/polysemy-monad @@ -0,0 +1 @@ +Replace Galley monad with polysemy's Sem throughout Galley diff --git a/hack/bin/split-member-constraints.py b/hack/bin/split-member-constraints.py new file mode 100644 index 00000000000..28a54e688cc --- /dev/null +++ b/hack/bin/split-member-constraints.py @@ -0,0 +1,33 @@ +#!/usr/bin/env python3 + +# This script splits all polysemy `Members` constraints into multiple `Member` +# constraints. The intended usage is to find redundant effects in function +# signatures. +# +# Example usage: +# +# $ git status # make sure working directory is clean +# $ fd -ehs services/galley/src -x hack/bin/split-member-constraints.py '{}' '{}' +# $ WIRE_STACK_OPTIONS="$WIRE_STACK_OPTIONS --ghc-options='-Wredundant-constraints -Wwarn'" make +# $ git reset --hard +# +# Now you can scroll back to find a list of redundant constraint warnings and +# fix them, but note that the line numbers are no longer accurate. + +import re +import sys + +def make_constraint(e): + e = e.strip() + if ' ' in e: + e = '(' + e + ')' + return f'Member {e} r' + +def f(m): + effects = re.split(r'\s*,\s*', m.group(1)) + constraints = ', '.join(make_constraint(e) for e in effects) + return f'({constraints})' + +code = open(sys.argv[1]).read() +print(re.sub(r"Members\s+'\[\s*([^\]]*)\s*\]\s+r", f, code, flags=re.MULTILINE), + file=open(sys.argv[2], 'w'), end='') diff --git a/libs/wire-api/src/Wire/API/Routes/Public.hs b/libs/wire-api/src/Wire/API/Routes/Public.hs index f52a0cc0fe9..9fd26ba7fe5 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public.hs @@ -18,43 +18,105 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Wire.API.Routes.Public where +module Wire.API.Routes.Public + ( -- * nginz combinators + ZUser, + ZLocalUser, + ZConn, + ZOptUser, + ZOptConn, + + -- * Swagger combinators + OmitDocs, + ) +where import Control.Lens ((<>~)) +import Data.Domain import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap import Data.Id as Id +import Data.Kind import Data.Metrics.Servant +import Data.Qualified import Data.Swagger import GHC.Base (Symbol) import GHC.TypeLits (KnownSymbol) import Imports hiding (All, head) import Servant hiding (Handler, JSON, addHeader, respond) -import Servant.API.Modifiers (FoldLenient, FoldRequired) +import Servant.API.Modifiers import Servant.Swagger (HasSwagger (toSwagger)) +mapRequestArgument :: + forall mods a b. + (SBoolI (FoldRequired mods), SBoolI (FoldLenient mods)) => + (a -> b) -> + RequestArgument mods a -> + RequestArgument mods b +mapRequestArgument f x = + case (sbool :: SBool (FoldRequired mods), sbool :: SBool (FoldLenient mods)) of + (STrue, STrue) -> fmap f x + (STrue, SFalse) -> f x + (SFalse, STrue) -> (fmap . fmap) f x + (SFalse, SFalse) -> fmap f x + -- This type exists for the special 'HasSwagger' and 'HasServer' instances. It -- shows the "Authorization" header in the swagger docs, but expects the -- "Z-Auth" header in the server. This helps keep the swagger docs usable -- through nginz. -data ZUserType = ZAuthUser | ZAuthConn +data ZType + = -- | Get a 'UserID' from the Z-Auth header + ZAuthUser + | -- | Same as 'ZAuthUser', but return a 'Local UserId' using the domain in the context + ZLocalAuthUser + | -- | Get a 'ConnId' from the Z-Conn header + ZAuthConn + +class + (KnownSymbol (ZHeader ztype), FromHttpApiData (ZParam ztype)) => + IsZType (ztype :: ZType) + where + type ZHeader ztype :: Symbol + type ZParam ztype :: * + type ZQualifiedParam ztype :: * + type ZConstraint ztype (ctx :: [*]) :: Constraint + + qualifyZParam :: ZConstraint ztype ctx => Context ctx -> ZParam ztype -> ZQualifiedParam ztype + +instance IsZType 'ZLocalAuthUser where + type ZHeader 'ZLocalAuthUser = "Z-User" + type ZParam 'ZLocalAuthUser = UserId + type ZQualifiedParam 'ZLocalAuthUser = Local UserId + type ZConstraint 'ZLocalAuthUser ctx = HasContextEntry ctx Domain + + qualifyZParam ctx = toLocalUnsafe (getContextEntry ctx) + +instance IsZType 'ZAuthUser where + type ZHeader 'ZAuthUser = "Z-User" + type ZParam 'ZAuthUser = UserId + type ZQualifiedParam 'ZAuthUser = UserId + type ZConstraint 'ZAuthUser ctx = () -type family ZUserHeader (ztype :: ZUserType) :: Symbol where - ZUserHeader 'ZAuthUser = "Z-User" - ZUserHeader 'ZAuthConn = "Z-Connection" + qualifyZParam _ = id -type family ZUserParam (ztype :: ZUserType) :: * where - ZUserParam 'ZAuthUser = UserId - ZUserParam 'ZAuthConn = ConnId +instance IsZType 'ZAuthConn where + type ZHeader 'ZAuthConn = "Z-Connection" + type ZParam 'ZAuthConn = ConnId + type ZQualifiedParam 'ZAuthConn = ConnId + type ZConstraint 'ZAuthConn ctx = () -data ZAuthServant (ztype :: ZUserType) (opts :: [*]) + qualifyZParam _ = id + +data ZAuthServant (ztype :: ZType) (opts :: [*]) type InternalAuthDefOpts = '[Servant.Required, Servant.Strict] type InternalAuth ztype opts = Header' opts - (ZUserHeader ztype) - (ZUserParam ztype) + (ZHeader ztype) + (ZParam ztype) + +type ZLocalUser = ZAuthServant 'ZLocalAuthUser InternalAuthDefOpts type ZUser = ZAuthServant 'ZAuthUser InternalAuthDefOpts @@ -76,24 +138,33 @@ instance HasSwagger api => HasSwagger (ZAuthServant 'ZAuthUser _opts :> api) whe _securitySchemeDescription = Just "Must be a token retrieved by calling 'POST /login' or 'POST /access'. It must be presented in this format: 'Bearer \\'." } +instance HasSwagger api => HasSwagger (ZAuthServant 'ZLocalAuthUser opts :> api) where + toSwagger _ = toSwagger (Proxy @(ZAuthServant 'ZAuthUser opts :> api)) + instance HasSwagger api => HasSwagger (ZAuthServant 'ZAuthConn _opts :> api) where toSwagger _ = toSwagger (Proxy @api) instance - ( HasContextEntry (ctx .++ DefaultErrorFormatters) ErrorFormatters, + ( IsZType ztype, + HasContextEntry (ctx .++ DefaultErrorFormatters) ErrorFormatters, + ZConstraint ztype ctx, SBoolI (FoldLenient opts), SBoolI (FoldRequired opts), - HasServer api ctx, - KnownSymbol (ZUserHeader ztype), - FromHttpApiData (ZUserParam ztype) + HasServer api ctx ) => HasServer (ZAuthServant ztype opts :> api) ctx where - type ServerT (ZAuthServant ztype opts :> api) m = ServerT (InternalAuth ztype opts :> api) m + type + ServerT (ZAuthServant ztype opts :> api) m = + RequestArgument opts (ZQualifiedParam ztype) -> ServerT api m - route _ = Servant.route (Proxy @(InternalAuth ztype opts :> api)) - hoistServerWithContext _ pc nt s = - Servant.hoistServerWithContext (Proxy @(InternalAuth ztype opts :> api)) pc nt s + route _ ctx subserver = + Servant.route + (Proxy @(InternalAuth ztype opts :> api)) + ctx + (fmap (. mapRequestArgument @opts (qualifyZParam @ztype ctx)) subserver) + + hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s instance RoutesToPaths api => RoutesToPaths (ZAuthServant ztype opts :> api) where getRoutes = getRoutes @api diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs b/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs index 136c82de3a9..20e2e00db2b 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs @@ -38,7 +38,7 @@ import Wire.API.ErrorDescription import Wire.API.Event.Conversation import Wire.API.Message import Wire.API.Routes.MultiVerb -import Wire.API.Routes.Public (ZConn, ZUser) +import Wire.API.Routes.Public import Wire.API.Routes.Public.Galley.Responses import Wire.API.Routes.Public.Util import Wire.API.Routes.QualifiedCapture @@ -78,21 +78,21 @@ data Api routes = Api getUnqualifiedConversation :: routes :- Summary "Get a conversation by ID" - :> ZUser + :> ZLocalUser :> "conversations" :> Capture "cnv" ConvId :> Get '[Servant.JSON] Conversation, getConversation :: routes :- Summary "Get a conversation by ID" - :> ZUser + :> ZLocalUser :> "conversations" :> QualifiedCapture "cnv" ConvId :> Get '[Servant.JSON] Conversation, getConversationRoles :: routes :- Summary "Get existing roles available for the given conversation" - :> ZUser + :> ZLocalUser :> "conversations" :> Capture "cnv" ConvId :> "roles" @@ -101,7 +101,7 @@ data Api routes = Api routes :- Summary "[deprecated] Get all local conversation IDs." -- FUTUREWORK: add bounds to swagger schema for Range - :> ZUser + :> ZLocalUser :> "conversations" :> "ids" :> QueryParam' @@ -133,7 +133,7 @@ data Api routes = Api \ `has_more` being `false`. Note that `paging_state` should be\ \ considered an opaque token. It should not be inspected, or stored, or\ \ reused across multiple unrelated invokations of the endpoint." - :> ZUser + :> ZLocalUser :> "conversations" :> "list-ids" :> ReqBody '[Servant.JSON] GetPaginatedConversationIds @@ -145,7 +145,7 @@ data Api routes = Api "Will not return remote conversations.\n\n\ \Use `POST /conversations/list-ids` followed by \ \`POST /conversations/list/v2` instead." - :> ZUser + :> ZLocalUser :> "conversations" :> QueryParam' [ Optional, @@ -172,7 +172,7 @@ data Api routes = Api listConversations :: routes :- Summary "Get conversation metadata for a list of conversation ids" - :> ZUser + :> ZLocalUser :> "conversations" :> "list" :> "v2" @@ -187,7 +187,7 @@ data Api routes = Api :> CanThrow CodeNotFound :> CanThrow ConvNotFound :> CanThrow ConvAccessDenied - :> ZUser + :> ZLocalUser :> "conversations" :> "join" :> QueryParam' [Required, Strict] "key" Code.Key @@ -200,7 +200,7 @@ data Api routes = Api :> CanThrow OperationDenied :> CanThrow NotATeamMember :> Description "This returns 201 when a new conversation is created, and 200 when the conversation already existed" - :> ZUser + :> ZLocalUser :> ZConn :> "conversations" :> ReqBody '[Servant.JSON] NewConvUnmanaged @@ -208,7 +208,7 @@ data Api routes = Api createSelfConversation :: routes :- Summary "Create a self-conversation" - :> ZUser + :> ZLocalUser :> "conversations" :> "self" :> ConversationVerb, @@ -218,7 +218,7 @@ data Api routes = Api createOne2OneConversation :: routes :- Summary "Create a 1:1 conversation" - :> ZUser + :> ZLocalUser :> ZConn :> "conversations" :> "one2one" @@ -233,7 +233,7 @@ data Api routes = Api :> CanThrow NotConnected :> CanThrow ConvAccessDenied :> CanThrow (InvalidOp "Invalid operation") - :> ZUser + :> ZLocalUser :> ZConn :> "conversations" :> Capture "cnv" ConvId @@ -243,7 +243,7 @@ data Api routes = Api addMembersToConversation :: routes :- Summary "Add qualified members to an existing conversation." - :> ZUser + :> ZLocalUser :> ZConn :> "conversations" :> Capture "cnv" ConvId @@ -256,7 +256,7 @@ data Api routes = Api removeMemberUnqualified :: routes :- Summary "Remove a member from a conversation (deprecated)" - :> ZUser + :> ZLocalUser :> ZConn :> "conversations" :> Capture' '[Description "Conversation ID"] "cnv" ConvId @@ -272,7 +272,7 @@ data Api routes = Api removeMember :: routes :- Summary "Remove a member from a conversation" - :> ZUser + :> ZLocalUser :> ZConn :> "conversations" :> QualifiedCapture' '[Description "Conversation ID"] "cnv" ConvId @@ -289,7 +289,7 @@ data Api routes = Api routes :- Summary "Update membership of the specified user (deprecated)" :> Description "Use `PUT /conversations/:cnv_domain/:cnv/members/:usr_domain/:usr` instead" - :> ZUser + :> ZLocalUser :> ZConn :> CanThrow ConvNotFound :> CanThrow ConvMemberNotFound @@ -308,7 +308,7 @@ data Api routes = Api routes :- Summary "Update membership of the specified user" :> Description "**Note**: at least one field has to be provided." - :> ZUser + :> ZLocalUser :> ZConn :> CanThrow ConvNotFound :> CanThrow ConvMemberNotFound @@ -329,7 +329,7 @@ data Api routes = Api routes :- Summary "Update conversation name (deprecated)" :> Description "Use `/conversations/:domain/:conv/name` instead." - :> ZUser + :> ZLocalUser :> ZConn :> "conversations" :> Capture' '[Description "Conversation ID"] "cnv" ConvId @@ -345,7 +345,7 @@ data Api routes = Api routes :- Summary "Update conversation name (deprecated)" :> Description "Use `/conversations/:domain/:conv/name` instead." - :> ZUser + :> ZLocalUser :> ZConn :> "conversations" :> Capture' '[Description "Conversation ID"] "cnv" ConvId @@ -361,7 +361,7 @@ data Api routes = Api updateConversationName :: routes :- Summary "Update conversation name" - :> ZUser + :> ZLocalUser :> ZConn :> "conversations" :> QualifiedCapture' '[Description "Conversation ID"] "cnv" ConvId @@ -380,7 +380,7 @@ data Api routes = Api routes :- Summary "Update the message timer for a conversation (deprecated)" :> Description "Use `/conversations/:domain/:cnv/message-timer` instead." - :> ZUser + :> ZLocalUser :> ZConn :> CanThrow ConvAccessDenied :> CanThrow ConvNotFound @@ -397,7 +397,7 @@ data Api routes = Api updateConversationMessageTimer :: routes :- Summary "Update the message timer for a conversation" - :> ZUser + :> ZLocalUser :> ZConn :> CanThrow ConvAccessDenied :> CanThrow ConvNotFound @@ -417,7 +417,7 @@ data Api routes = Api routes :- Summary "Update receipt mode for a conversation (deprecated)" :> Description "Use `PUT /conversations/:domain/:cnv/receipt-mode` instead." - :> ZUser + :> ZLocalUser :> ZConn :> CanThrow ConvAccessDenied :> CanThrow ConvNotFound @@ -433,7 +433,7 @@ data Api routes = Api updateConversationReceiptMode :: routes :- Summary "Update receipt mode for a conversation" - :> ZUser + :> ZLocalUser :> ZConn :> CanThrow ConvAccessDenied :> CanThrow ConvNotFound @@ -453,7 +453,7 @@ data Api routes = Api routes :- Summary "Update access modes for a conversation (deprecated)" :> Description "Use PUT `/conversations/:domain/:cnv/access` instead." - :> ZUser + :> ZLocalUser :> ZConn :> CanThrow ConvAccessDenied :> CanThrow ConvNotFound @@ -470,7 +470,7 @@ data Api routes = Api updateConversationAccess :: routes :- Summary "Update access modes for a conversation" - :> ZUser + :> ZLocalUser :> ZConn :> CanThrow ConvAccessDenied :> CanThrow ConvNotFound @@ -487,7 +487,7 @@ data Api routes = Api getConversationSelfUnqualified :: routes :- Summary "Get self membership properties (deprecated)" - :> ZUser + :> ZLocalUser :> "conversations" :> Capture' '[Description "Conversation ID"] "cnv" ConvId :> "self" @@ -497,7 +497,7 @@ data Api routes = Api :- Summary "Update self membership properties (deprecated)" :> Description "Use `/conversations/:domain/:conv/self` instead." :> CanThrow ConvNotFound - :> ZUser + :> ZLocalUser :> ZConn :> "conversations" :> Capture' '[Description "Conversation ID"] "cnv" ConvId @@ -513,7 +513,7 @@ data Api routes = Api :- Summary "Update self membership properties" :> Description "**Note**: at least one field has to be provided." :> CanThrow ConvNotFound - :> ZUser + :> ZLocalUser :> ZConn :> "conversations" :> QualifiedCapture' '[Description "Conversation ID"] "cnv" ConvId @@ -560,7 +560,7 @@ data Api routes = Api :- Summary "Remove a team conversation" :> CanThrow NotATeamMember :> CanThrow ActionDenied - :> ZUser + :> ZLocalUser :> ZConn :> "teams" :> Capture "tid" TeamId @@ -571,7 +571,7 @@ data Api routes = Api routes :- Summary "Post an encrypted message to a conversation (accepts JSON or Protobuf)" :> Description PostOtrDescriptionUnqualified - :> ZUser + :> ZLocalUser :> ZConn :> "conversations" :> Capture "cnv" ConvId @@ -589,7 +589,7 @@ data Api routes = Api routes :- Summary "Post an encrypted message to a conversation (accepts only Protobuf)" :> Description PostOtrDescription - :> ZUser + :> ZLocalUser :> ZConn :> "conversations" :> QualifiedCapture "cnv" ConvId diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index 7eeb2c3d6b9..b1f68193ca3 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 6f378c75d7938aa5f221f136049c8ca98f63e7ae682e0035fb912f3917cfd1b1 +-- hash: 955ba4e571c8a43aab5b78d001425cbc40f17e59b95bfabb8ab5d42bae6500b5 name: galley version: 0.83.0 @@ -87,6 +87,7 @@ library Galley.Effects.ListItems Galley.Effects.MemberStore Galley.Effects.Paging + Galley.Effects.Queue Galley.Effects.RemoteConversationListStore Galley.Effects.SearchVisibilityStore Galley.Effects.ServiceStore @@ -95,9 +96,12 @@ library Galley.Effects.TeamMemberStore Galley.Effects.TeamNotificationStore Galley.Effects.TeamStore + Galley.Effects.WaiRoutes + Galley.Effects.WaiRoutes.IO Galley.Env Galley.External Galley.External.LegalHoldService + Galley.External.LegalHoldService.Internal Galley.External.LegalHoldService.Types Galley.Intra.Client Galley.Intra.Effects @@ -110,6 +114,7 @@ library Galley.Intra.Team Galley.Intra.User Galley.Intra.Util + Galley.Monad Galley.Options Galley.Queue Galley.Run @@ -123,7 +128,7 @@ library hs-source-dirs: src default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DerivingVia DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path -fplugin=Polysemy.Plugin + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path build-depends: HsOpenSSL >=0.11 , HsOpenSSL-x509-system >=0.1 @@ -169,7 +174,6 @@ library , optparse-applicative >=0.10 , pem , polysemy - , polysemy-plugin , polysemy-wire-zoo , proto-lens >=0.2 , protobuf >=0.2 diff --git a/services/galley/package.yaml b/services/galley/package.yaml index c7c5a15ff8c..c97f956613d 100644 --- a/services/galley/package.yaml +++ b/services/galley/package.yaml @@ -26,7 +26,6 @@ dependencies: library: source-dirs: src - ghc-options: -fplugin=Polysemy.Plugin dependencies: - aeson >=0.11 - amazonka >=1.4.5 @@ -67,7 +66,6 @@ library: - optparse-applicative >=0.10 - pem - polysemy - - polysemy-plugin - polysemy-wire-zoo - protobuf >=0.2 - proto-lens >=0.2 diff --git a/services/galley/src/Galley/API.hs b/services/galley/src/Galley/API.hs index 122c06859f1..1ae9c9a234d 100644 --- a/services/galley/src/Galley/API.hs +++ b/services/galley/src/Galley/API.hs @@ -24,10 +24,11 @@ where import qualified Data.Swagger.Build.Api as Doc import qualified Galley.API.Internal as Internal import qualified Galley.API.Public as Public -import Galley.App (Galley, GalleyEffects) +import Galley.App (GalleyEffects) import Network.Wai.Routing (Routes) +import Polysemy -sitemap :: Routes Doc.ApiBuilder (Galley GalleyEffects) () +sitemap :: Routes Doc.ApiBuilder (Sem GalleyEffects) () sitemap = do Public.sitemap Public.apiDocs diff --git a/services/galley/src/Galley/API/Action.hs b/services/galley/src/Galley/API/Action.hs index 4f3e508b11e..957ccea7821 100644 --- a/services/galley/src/Galley/API/Action.hs +++ b/services/galley/src/Galley/API/Action.hs @@ -27,6 +27,7 @@ module Galley.API.Action -- * Performing actions updateLocalConversation, + NoChanges, -- * Utilities ensureConversationActionAllowed, @@ -37,7 +38,6 @@ where import qualified Brig.Types.User as User import Control.Lens -import Control.Monad.Trans.Maybe import Data.Id import Data.Kind import Data.List.NonEmpty (NonEmpty, nonEmpty) @@ -47,7 +47,6 @@ import qualified Data.Set as Set import Data.Time.Clock import Galley.API.Error import Galley.API.Util -import Galley.App import Galley.Data.Conversation import Galley.Data.Services import Galley.Data.Types @@ -57,14 +56,17 @@ import qualified Galley.Effects.BrigAccess as E import qualified Galley.Effects.CodeStore as E import qualified Galley.Effects.ConversationStore as E import qualified Galley.Effects.FederatorAccess as E +import qualified Galley.Effects.FireAndForget as E import qualified Galley.Effects.MemberStore as E import qualified Galley.Effects.TeamStore as E +import Galley.Options import Galley.Types.Conversations.Members import Galley.Types.UserList import Galley.Validation import Imports import Polysemy import Polysemy.Error +import Polysemy.Input import Wire.API.Conversation hiding (Conversation, Member) import Wire.API.Conversation.Action import Wire.API.Conversation.Role @@ -75,6 +77,11 @@ import Wire.API.Federation.Client import Wire.API.Team.LegalHold import Wire.API.Team.Member +data NoChanges = NoChanges + +noChanges :: Member (Error NoChanges) r => Sem r a +noChanges = throw NoChanges + -- | An update to a conversation, including addition and removal of members. -- Used to send notifications to users and to remote backends. class IsConversationAction a where @@ -87,18 +94,18 @@ class IsConversationAction a where a -> Conversation -> mem -> - Galley r () + Sem r () ensureAllowed _ _ _ _ = pure () conversationActionTag' :: Qualified UserId -> a -> Action performAction :: ( HasConversationActionEffects a r, - Members '[ConversationStore] r + Members '[ConversationStore, Error NoChanges] r ) => Qualified UserId -> Local ConvId -> Conversation -> a -> - MaybeT (Galley r) (BotsAndMembers, a) + Sem r (BotsAndMembers, a) -- | The action of some users joining a conversation. data ConversationJoin = ConversationJoin @@ -133,6 +140,8 @@ instance IsConversationAction ConversationJoin where ExternalAccess, FederatorAccess, GundeckAccess, + Input Opts, + Input UTCTime, LegalHoldStore, MemberStore, TeamStore @@ -145,14 +154,13 @@ instance IsConversationAction ConversationJoin where performAction qusr lcnv conv (ConversationJoin invited role) = do let newMembers = ulNewMembers lcnv conv . toUserList lcnv $ invited - lift $ do - lusr <- liftSem $ ensureLocal lcnv qusr - ensureMemberLimit (toList (convLocalMembers conv)) newMembers - liftSem $ ensureAccess conv InviteAccess - checkLocals lusr (convTeam conv) (ulLocals newMembers) - checkRemotes lusr (ulRemotes newMembers) - checkLHPolicyConflictsLocal (ulLocals newMembers) - checkLHPolicyConflictsRemote (FutureWork (ulRemotes newMembers)) + lusr <- ensureLocal lcnv qusr + ensureMemberLimit (toList (convLocalMembers conv)) newMembers + ensureAccess conv InviteAccess + checkLocals lusr (convTeam conv) (ulLocals newMembers) + checkRemotes lusr (ulRemotes newMembers) + checkLHPolicyConflictsLocal (ulLocals newMembers) + checkLHPolicyConflictsRemote (FutureWork (ulRemotes newMembers)) addMembersToLocalConversation lcnv newMembers role where @@ -170,9 +178,9 @@ instance IsConversationAction ConversationJoin where Local UserId -> Maybe TeamId -> [UserId] -> - Galley r () + Sem r () checkLocals lusr (Just tid) newUsers = do - tms <- liftSem $ E.selectTeamMembers tid newUsers + tms <- E.selectTeamMembers tid newUsers let userMembershipMap = map (\u -> (u, find (userIsMember u) tms)) newUsers ensureAccessRole (convAccessRole conv) userMembershipMap ensureConnectedOrSameTeam lusr newUsers @@ -181,16 +189,21 @@ instance IsConversationAction ConversationJoin where ensureConnectedOrSameTeam lusr newUsers checkRemotes :: - Members '[BrigAccess, Error ActionError, Error FederationError, TeamStore] r => + Members + '[ BrigAccess, + Error ActionError, + Error FederationError, + FederatorAccess + ] + r => Local UserId -> [Remote UserId] -> - Galley r () + Sem r () checkRemotes lusr remotes = do -- if federator is not configured, we fail early, so we avoid adding -- remote members to the database - unless (null remotes) $ do - endpoint <- federatorEndpoint - liftSem . when (isNothing endpoint) $ + unless (null remotes) $ + unlessM E.isFederationConfigured $ throw FederationNotConfigured ensureConnectedToRemotes lusr remotes @@ -204,13 +217,15 @@ instance IsConversationAction ConversationJoin where ExternalAccess, FederatorAccess, GundeckAccess, + Input Opts, + Input UTCTime, LegalHoldStore, MemberStore, TeamStore ] r => [UserId] -> - Galley r () + Sem r () checkLHPolicyConflictsLocal newUsers = do let convUsers = convLocalMembers conv @@ -218,11 +233,11 @@ instance IsConversationAction ConversationJoin where whenM (anyLegalholdActivated (lmId <$> convUsers)) $ unless allNewUsersGaveConsent $ - liftSem $ throw MissingLegalholdConsent + throw MissingLegalholdConsent whenM (anyLegalholdActivated newUsers) $ do unless allNewUsersGaveConsent $ - liftSem $ throw MissingLegalholdConsent + throw MissingLegalholdConsent convUsersLHStatus <- do uidsStatus <- getLHStatusForUsers (lmId <$> convUsers) @@ -237,15 +252,15 @@ instance IsConversationAction ConversationJoin where then do for_ convUsersLHStatus $ \(mem, status) -> when (consentGiven status == ConsentNotGiven) $ do - qvictim <- qUntagged <$> qualifyLocal (lmId mem) - void . runMaybeT $ + let qvictim = qUntagged (qualifyAs lcnv (lmId mem)) + void . runError @NoChanges $ updateLocalConversation lcnv qvictim Nothing $ ConversationLeave (pure qvictim) - else liftSem $ throw MissingLegalholdConsent + else throw MissingLegalholdConsent checkLHPolicyConflictsRemote :: FutureWork 'LegalholdPlusFederationNotImplemented [Remote UserId] -> - Galley r () + Sem r () checkLHPolicyConflictsRemote _remotes = pure () instance IsConversationAction ConversationLeave where @@ -258,8 +273,8 @@ instance IsConversationAction ConversationLeave where | otherwise = RemoveConversationMember performAction _qusr lcnv conv action = do let presentVictims = filter (isConvMember lcnv conv) (toList (clUsers action)) - guard . not . null $ presentVictims - lift . liftSem $ E.deleteMembers (convId conv) (toUserList lcnv presentVictims) + when (null presentVictims) noChanges + E.deleteMembers (convId conv) (toUserList lcnv presentVictims) pure (mempty, action) -- FUTUREWORK: should we return the filtered action here? instance IsConversationAction ConversationMemberUpdate where @@ -268,7 +283,7 @@ instance IsConversationAction ConversationMemberUpdate where (Members '[MemberStore, Error ConversationError] r) conversationAction cmu = ConversationActionMemberUpdate (cmuTarget cmu) (cmuUpdate cmu) conversationActionTag' _ _ = ModifyOtherConversationMember - performAction _qusr lcnv conv action = lift . liftSem $ do + performAction _qusr lcnv conv action = do void $ ensureOtherMember lcnv (cmuTarget action) conv E.setOtherMember lcnv (cmuTarget action) (cmuUpdate action) pure (mempty, action) @@ -279,11 +294,11 @@ instance IsConversationAction ConversationDelete where Members '[Error FederationError, Error NotATeamMember, CodeStore, TeamStore] r conversationAction ConversationDelete = ConversationActionDelete ensureAllowed loc ConversationDelete conv self = - liftSem . for_ (convTeam conv) $ \tid -> do + for_ (convTeam conv) $ \tid -> do lusr <- ensureLocal loc (convMemberId loc self) void $ E.getTeamMember tid (tUnqualified lusr) >>= noteED @NotATeamMember conversationActionTag' _ _ = DeleteConversation - performAction _ lcnv conv action = lift . liftSem $ do + performAction _ lcnv conv action = do key <- E.makeKey (tUnqualified lcnv) E.deleteCode key ReusableCode case convTeam conv of @@ -298,7 +313,7 @@ instance IsConversationAction ConversationRename where conversationAction = ConversationActionRename conversationActionTag' _ _ = ModifyConversationName - performAction _ lcnv _ action = lift . liftSem $ do + performAction _ lcnv _ action = do cn <- rangeChecked (cupName action) E.setConversationName (tUnqualified lcnv) cn pure (mempty, action) @@ -308,8 +323,8 @@ instance IsConversationAction ConversationMessageTimerUpdate where conversationAction = ConversationActionMessageTimerUpdate conversationActionTag' _ _ = ModifyConversationMessageTimer performAction _ lcnv conv action = do - guard $ convMessageTimer conv /= cupMessageTimer action - lift . liftSem $ E.setConversationMessageTimer (tUnqualified lcnv) (cupMessageTimer action) + when (convMessageTimer conv == cupMessageTimer action) noChanges + E.setConversationMessageTimer (tUnqualified lcnv) (cupMessageTimer action) pure (mempty, action) instance IsConversationAction ConversationReceiptModeUpdate where @@ -317,8 +332,8 @@ instance IsConversationAction ConversationReceiptModeUpdate where conversationAction = ConversationActionReceiptModeUpdate conversationActionTag' _ _ = ModifyConversationReceiptMode performAction _ lcnv conv action = do - guard $ convReceiptMode conv /= Just (cruReceiptMode action) - lift . liftSem $ E.setConversationReceiptMode (tUnqualified lcnv) (cruReceiptMode action) + when (convReceiptMode conv == Just (cruReceiptMode action)) noChanges + E.setConversationReceiptMode (tUnqualified lcnv) (cruReceiptMode action) pure (mempty, action) instance IsConversationAction ConversationAccessData where @@ -335,7 +350,8 @@ instance IsConversationAction ConversationAccessData where FireAndForget, GundeckAccess, MemberStore, - TeamStore + TeamStore, + Input UTCTime ] r conversationAction = ConversationActionAccessUpdate @@ -343,12 +359,11 @@ instance IsConversationAction ConversationAccessData where -- 'PrivateAccessRole' is for self-conversations, 1:1 conversations and -- so on; users are not supposed to be able to make other conversations -- have 'PrivateAccessRole' - liftSem $ - when - ( PrivateAccess `elem` cupAccess target - || PrivateAccessRole == cupAccessRole target - ) - $ throw InvalidTargetAccess + when + ( PrivateAccess `elem` cupAccess target + || PrivateAccessRole == cupAccessRole target + ) + $ throw InvalidTargetAccess -- Team conversations incur another round of checks case convTeam conv of Just _ -> do @@ -356,32 +371,31 @@ instance IsConversationAction ConversationAccessData where -- conversation, so the user must have the necessary permission flag ensureActionAllowed RemoveConversationMember self Nothing -> - liftSem $ - when (cupAccessRole target == TeamAccessRole) $ - throw InvalidTargetAccess + when (cupAccessRole target == TeamAccessRole) $ + throw InvalidTargetAccess conversationActionTag' _ _ = ModifyConversationAccess performAction qusr lcnv conv action = do - guard $ convAccessData conv /= action + when (convAccessData conv == action) noChanges -- Remove conversation codes if CodeAccess is revoked when ( CodeAccess `elem` convAccess conv && CodeAccess `notElem` cupAccess action ) - $ lift $ do - key <- mkKey (tUnqualified lcnv) - liftSem $ E.deleteCode key ReusableCode + $ do + key <- E.makeKey (tUnqualified lcnv) + E.deleteCode key ReusableCode -- Determine bots and members to be removed let filterBotsAndMembers = filterActivated >=> filterTeammates let current = convBotsAndMembers conv -- initial bots and members - desired <- lift . liftSem $ filterBotsAndMembers current -- desired bots and members + desired <- filterBotsAndMembers current -- desired bots and members let toRemove = bmDiff current desired -- bots and members to be removed -- Update Cassandra - lift . liftSem $ E.setConversationAccess (tUnqualified lcnv) action - lift . fireAndForget $ do + E.setConversationAccess (tUnqualified lcnv) action + E.fireAndForget $ do -- Remove bots - traverse_ (liftSem . E.deleteBot (tUnqualified lcnv) . botMemId) (bmBots toRemove) + traverse_ (E.deleteBot (tUnqualified lcnv) . botMemId) (bmBots toRemove) -- Update current bots and members let current' = current {bmBots = bmBots desired} @@ -389,7 +403,7 @@ instance IsConversationAction ConversationAccessData where -- Remove users and notify everyone void . for_ (nonEmpty (bmQualifiedMembers lcnv toRemove)) $ \usersToRemove -> do let rAction = ConversationLeave usersToRemove - void . runMaybeT $ performAction qusr lcnv conv rAction + void . runError @NoChanges $ performAction qusr lcnv conv rAction notifyConversationAction qusr Nothing lcnv current' (conversationAction rAction) pure (mempty, action) where @@ -425,9 +439,11 @@ updateLocalConversation :: Error ActionError, Error ConversationError, Error InvalidInput, + Error NoChanges, ExternalAccess, FederatorAccess, - GundeckAccess + GundeckAccess, + Input UTCTime ] r, HasConversationActionEffects a r @@ -436,27 +452,24 @@ updateLocalConversation :: Qualified UserId -> Maybe ConnId -> a -> - MaybeT (Galley r) Event + Sem r Event updateLocalConversation lcnv qusr con action = do -- retrieve conversation - (conv, self) <- - lift $ - getConversationAndMemberWithError ConvNotFound qusr (tUnqualified lcnv) + (conv, self) <- getConversationAndMemberWithError ConvNotFound qusr lcnv -- perform checks - lift $ ensureConversationActionAllowed lcnv action conv self + ensureConversationActionAllowed lcnv action conv self -- perform action (extraTargets, action') <- performAction qusr lcnv conv action -- send notifications to both local and remote users - lift $ - notifyConversationAction - qusr - con - lcnv - (convBotsAndMembers conv <> extraTargets) - (conversationAction action') + notifyConversationAction + qusr + con + lcnv + (convBotsAndMembers conv <> extraTargets) + (conversationAction action') -------------------------------------------------------------------------------- -- Utilities @@ -471,49 +484,47 @@ ensureConversationActionAllowed :: a -> Conversation -> mem -> - Galley r () + Sem r () ensureConversationActionAllowed loc action conv self = do let tag = conversationActionTag' (convMemberId loc self) action -- general action check ensureActionAllowed tag self -- check if it is a group conversation (except for rename actions) when (tag /= ModifyConversationName) $ - liftSem $ ensureGroupConversation conv + ensureGroupConversation conv -- extra action-specific checks ensureAllowed loc action conv self -- | Add users to a conversation without performing any checks. Return extra -- notification targets and the action performed. addMembersToLocalConversation :: - Members '[MemberStore] r => + Members '[MemberStore, Error NoChanges] r => Local ConvId -> UserList UserId -> RoleName -> - MaybeT (Galley r) (BotsAndMembers, ConversationJoin) + Sem r (BotsAndMembers, ConversationJoin) addMembersToLocalConversation lcnv users role = do - (lmems, rmems) <- lift . liftSem $ E.createMembers (tUnqualified lcnv) (fmap (,role) users) - neUsers <- maybe mzero pure . nonEmpty . ulAll lcnv $ users + (lmems, rmems) <- E.createMembers (tUnqualified lcnv) (fmap (,role) users) + neUsers <- note NoChanges $ nonEmpty (ulAll lcnv users) let action = ConversationJoin neUsers role pure (bmFromMembers lmems rmems, action) notifyConversationAction :: - Members '[FederatorAccess, ExternalAccess, GundeckAccess] r => + Members '[FederatorAccess, ExternalAccess, GundeckAccess, Input UTCTime] r => Qualified UserId -> Maybe ConnId -> Local ConvId -> BotsAndMembers -> ConversationAction -> - Galley r Event -notifyConversationAction quid con (qUntagged -> qcnv) targets action = do - localDomain <- viewFederationDomain - now <- liftIO getCurrentTime - let e = conversationActionToEvent now quid qcnv action + Sem r Event +notifyConversationAction quid con lcnv targets action = do + now <- input + let e = conversationActionToEvent now quid (qUntagged lcnv) action -- notify remote participants - liftSem $ - E.runFederatedConcurrently_ (toList (bmRemotes targets)) $ \ruids -> - F.onConversationUpdated F.clientRoutes localDomain $ - F.ConversationUpdate now quid (qUnqualified qcnv) (tUnqualified ruids) action + E.runFederatedConcurrently_ (toList (bmRemotes targets)) $ \ruids -> + F.onConversationUpdated F.clientRoutes (tDomain lcnv) $ + F.ConversationUpdate now quid (tUnqualified lcnv) (tUnqualified ruids) action -- notify local participants and bots - pushConversationEvent con e (bmLocals targets) (bmBots targets) $> e + pushConversationEvent con e (qualifyAs lcnv (bmLocals targets)) (bmBots targets) $> e diff --git a/services/galley/src/Galley/API/Clients.hs b/services/galley/src/Galley/API/Clients.hs index 8d209b5765f..ec2ede0a808 100644 --- a/services/galley/src/Galley/API/Clients.hs +++ b/services/galley/src/Galley/API/Clients.hs @@ -22,51 +22,48 @@ module Galley.API.Clients ) where -import Control.Lens (view) import Data.Id -import Galley.App import Galley.Effects import qualified Galley.Effects.BrigAccess as E import qualified Galley.Effects.ClientStore as E -import Galley.Options import Galley.Types.Clients (clientIds, fromUserClients) import Imports import Network.Wai import Network.Wai.Predicate hiding (setStatus) import Network.Wai.Utilities +import Polysemy getClientsH :: Members '[BrigAccess, ClientStore] r => UserId -> - Galley r Response + Sem r Response getClientsH usr = do json <$> getClients usr getClients :: Members '[BrigAccess, ClientStore] r => UserId -> - Galley r [ClientId] + Sem r [ClientId] getClients usr = do - isInternal <- view $ options . optSettings . setIntraListing + isInternal <- E.useIntraClientListing clts <- - liftSem $ - if isInternal - then fromUserClients <$> E.lookupClients [usr] - else E.getClients [usr] + if isInternal + then fromUserClients <$> E.lookupClients [usr] + else E.getClients [usr] return $ clientIds usr clts addClientH :: Member ClientStore r => UserId ::: ClientId -> - Galley r Response -addClientH (usr ::: clt) = liftSem $ do + Sem r Response +addClientH (usr ::: clt) = do E.createClient usr clt return empty rmClientH :: Member ClientStore r => UserId ::: ClientId -> - Galley r Response -rmClientH (usr ::: clt) = liftSem $ do + Sem r Response +rmClientH (usr ::: clt) = do E.deleteClient usr clt return empty diff --git a/services/galley/src/Galley/API/Create.hs b/services/galley/src/Galley/API/Create.hs index 8c4b698bf38..4e8df3936b4 100644 --- a/services/galley/src/Galley/API/Create.hs +++ b/services/galley/src/Galley/API/Create.hs @@ -36,7 +36,6 @@ import Galley.API.Error import Galley.API.Mapping import Galley.API.One2One import Galley.API.Util -import Galley.App import qualified Galley.Data.Conversation as Data import Galley.Data.Conversation.Types import Galley.Effects @@ -44,7 +43,9 @@ import qualified Galley.Effects.ConversationStore as E import qualified Galley.Effects.GundeckAccess as E import qualified Galley.Effects.MemberStore as E import qualified Galley.Effects.TeamStore as E +import Galley.Effects.WaiRoutes import Galley.Intra.Push +import Galley.Options import Galley.Types.Conversations.Members import Galley.Types.Teams (ListType (..), Perm (..), TeamBinding (Binding), notTeamMember) import Galley.Types.UserList @@ -56,6 +57,8 @@ import Network.Wai.Predicate hiding (Error, setStatus) import Network.Wai.Utilities hiding (Error) import Polysemy import Polysemy.Error +import Polysemy.Input +import qualified Polysemy.TinyLog as P import Wire.API.Conversation hiding (Conversation, Member) import qualified Wire.API.Conversation as Public import Wire.API.ErrorDescription @@ -81,17 +84,19 @@ createGroupConversation :: Error InvalidInput, Error LegalHoldError, Error NotATeamMember, - Error TeamError, FederatorAccess, GundeckAccess, + Input Opts, + Input UTCTime, LegalHoldStore, - TeamStore + TeamStore, + P.TinyLog ] r => - UserId -> + Local UserId -> ConnId -> Public.NewConvUnmanaged -> - Galley r ConversationResponse + Sem r ConversationResponse createGroupConversation user conn wrapped@(Public.NewConvUnmanaged body) = case newConvTeam body of Nothing -> createRegularGroupConv user conn wrapped @@ -109,18 +114,23 @@ internalCreateManagedConversationH :: Error InvalidInput, Error LegalHoldError, Error NotATeamMember, - Error TeamError, FederatorAccess, GundeckAccess, + Input (Local ()), + Input Opts, + Input UTCTime, LegalHoldStore, - TeamStore + TeamStore, + P.TinyLog, + WaiRoutes ] r => UserId ::: ConnId ::: JsonRequest NewConvManaged -> - Galley r Response + Sem r Response internalCreateManagedConversationH (zusr ::: zcon ::: req) = do + lusr <- qualifyLocal zusr newConv <- fromJsonBody req - handleConversationResponse <$> internalCreateManagedConversation zusr zcon newConv + handleConversationResponse <$> internalCreateManagedConversation lusr zcon newConv internalCreateManagedConversation :: Members @@ -132,31 +142,33 @@ internalCreateManagedConversation :: Error InvalidInput, Error LegalHoldError, Error NotATeamMember, - Error TeamError, FederatorAccess, GundeckAccess, + Input Opts, LegalHoldStore, - TeamStore + Input UTCTime, + TeamStore, + P.TinyLog ] r => - UserId -> + Local UserId -> ConnId -> NewConvManaged -> - Galley r ConversationResponse -internalCreateManagedConversation zusr zcon (NewConvManaged body) = do - tinfo <- liftSem $ note CannotCreateManagedConv (newConvTeam body) - createTeamGroupConv zusr zcon tinfo body + Sem r ConversationResponse +internalCreateManagedConversation lusr zcon (NewConvManaged body) = do + tinfo <- note CannotCreateManagedConv (newConvTeam body) + createTeamGroupConv lusr zcon tinfo body ensureNoLegalholdConflicts :: - Members '[Error LegalHoldError, LegalHoldStore, TeamStore] r => + Members '[Error LegalHoldError, Input Opts, LegalHoldStore, TeamStore] r => [Remote UserId] -> [UserId] -> - Galley r () + Sem r () ensureNoLegalholdConflicts remotes locals = do let FutureWork _remotes = FutureWork @'LegalholdPlusFederationNotImplemented remotes whenM (anyLegalholdActivated locals) $ unlessM (allLegalholdConsentGiven locals) $ - liftSem $ throw MissingLegalholdConsent + throw MissingLegalholdConsent -- | A helper for creating a regular (non-team) group conversation. createRegularGroupConv :: @@ -169,39 +181,40 @@ createRegularGroupConv :: Error InvalidInput, Error LegalHoldError, GundeckAccess, + Input Opts, + Input UTCTime, LegalHoldStore, - TeamStore + TeamStore, + P.TinyLog ] r => - UserId -> + Local UserId -> ConnId -> NewConvUnmanaged -> - Galley r ConversationResponse -createRegularGroupConv zusr zcon (NewConvUnmanaged body) = do - lusr <- qualifyLocal zusr - name <- liftSem $ rangeCheckedMaybe (newConvName body) + Sem r ConversationResponse +createRegularGroupConv lusr zcon (NewConvUnmanaged body) = do + name <- rangeCheckedMaybe (newConvName body) let allUsers = newConvMembers lusr body - o <- view options - checkedUsers <- liftSem $ checkedConvSize o allUsers + o <- input + checkedUsers <- checkedConvSize o allUsers ensureConnected lusr allUsers ensureNoLegalholdConflicts (ulRemotes allUsers) (ulLocals allUsers) c <- - liftSem $ - E.createConversation - NewConversation - { ncType = RegularConv, - ncCreator = tUnqualified lusr, - ncAccess = access body, - ncAccessRole = accessRole body, - ncName = name, - ncTeam = fmap cnvTeamId (newConvTeam body), - ncMessageTimer = newConvMessageTimer body, - ncReceiptMode = newConvReceiptMode body, - ncUsers = checkedUsers, - ncRole = newConvUsersRole body - } - notifyCreatedConversation Nothing zusr (Just zcon) c - conversationCreated zusr c + E.createConversation + NewConversation + { ncType = RegularConv, + ncCreator = tUnqualified lusr, + ncAccess = access body, + ncAccessRole = accessRole body, + ncName = name, + ncTeam = fmap cnvTeamId (newConvTeam body), + ncMessageTimer = newConvMessageTimer body, + ncReceiptMode = newConvReceiptMode body, + ncUsers = checkedUsers, + ncRole = newConvUsersRole body + } + notifyCreatedConversation Nothing lusr (Just zcon) c + conversationCreated lusr c -- | A helper for creating a team group conversation, used by the endpoint -- handlers above. Only supports unmanaged conversations. @@ -215,29 +228,30 @@ createTeamGroupConv :: Error InvalidInput, Error LegalHoldError, Error NotATeamMember, - Error TeamError, FederatorAccess, GundeckAccess, + Input Opts, + Input UTCTime, LegalHoldStore, - TeamStore + TeamStore, + P.TinyLog ] r => - UserId -> + Local UserId -> ConnId -> Public.ConvTeamInfo -> Public.NewConv -> - Galley r ConversationResponse -createTeamGroupConv zusr zcon tinfo body = do - lusr <- qualifyLocal zusr - name <- liftSem $ rangeCheckedMaybe (newConvName body) + Sem r ConversationResponse +createTeamGroupConv lusr zcon tinfo body = do + name <- rangeCheckedMaybe (newConvName body) let allUsers = newConvMembers lusr body convTeam = cnvTeamId tinfo - zusrMembership <- liftSem $ E.getTeamMember convTeam zusr + zusrMembership <- E.getTeamMember convTeam (tUnqualified lusr) void $ permissionCheck CreateConversation zusrMembership - o <- view options - checkedUsers <- liftSem $ checkedConvSize o allUsers - convLocalMemberships <- mapM (liftSem . E.getTeamMember convTeam) (ulLocals allUsers) + o <- input + checkedUsers <- checkedConvSize o allUsers + convLocalMemberships <- mapM (E.getTeamMember convTeam) (ulLocals allUsers) ensureAccessRole (accessRole body) (zip (ulLocals allUsers) convLocalMemberships) -- In teams we don't have 1:1 conversations, only regular conversations. We want -- users without the 'AddRemoveConvMember' permission to still be able to create @@ -253,44 +267,44 @@ createTeamGroupConv zusr zcon tinfo body = do void $ permissionCheck DoNotUseDeprecatedAddRemoveConvMember zusrMembership -- Team members are always considered to be connected, so we only check -- 'ensureConnected' for non-team-members. - ensureConnectedToLocals zusr (notTeamMember (ulLocals allUsers) (catMaybes convLocalMemberships)) + ensureConnectedToLocals (tUnqualified lusr) (notTeamMember (ulLocals allUsers) (catMaybes convLocalMemberships)) ensureConnectedToRemotes lusr (ulRemotes allUsers) ensureNoLegalholdConflicts (ulRemotes allUsers) (ulLocals allUsers) conv <- - liftSem $ - E.createConversation - NewConversation - { ncType = RegularConv, - ncCreator = tUnqualified lusr, - ncAccess = access body, - ncAccessRole = accessRole body, - ncName = name, - ncTeam = fmap cnvTeamId (newConvTeam body), - ncMessageTimer = newConvMessageTimer body, - ncReceiptMode = newConvReceiptMode body, - ncUsers = checkedUsers, - ncRole = newConvUsersRole body - } - now <- liftIO getCurrentTime + E.createConversation + NewConversation + { ncType = RegularConv, + ncCreator = tUnqualified lusr, + ncAccess = access body, + ncAccessRole = accessRole body, + ncName = name, + ncTeam = fmap cnvTeamId (newConvTeam body), + ncMessageTimer = newConvMessageTimer body, + ncReceiptMode = newConvReceiptMode body, + ncUsers = checkedUsers, + ncRole = newConvUsersRole body + } + now <- input -- NOTE: We only send (conversation) events to members of the conversation - notifyCreatedConversation (Just now) zusr (Just zcon) conv - conversationCreated zusr conv + notifyCreatedConversation (Just now) lusr (Just zcon) conv + conversationCreated lusr conv ---------------------------------------------------------------------------- -- Other kinds of conversations createSelfConversation :: - Members '[ConversationStore, Error InternalError] r => - UserId -> - Galley r ConversationResponse -createSelfConversation zusr = do - lusr <- qualifyLocal zusr - c <- liftSem $ E.getConversation (Id . toUUID $ zusr) - maybe (create lusr) (conversationExisted zusr) c + forall r. + Members '[ConversationStore, Error InternalError, P.TinyLog] r => + Local UserId -> + Sem r ConversationResponse +createSelfConversation lusr = do + c <- E.getConversation (Id . toUUID . tUnqualified $ lusr) + maybe create (conversationExisted lusr) c where - create lusr = do - c <- liftSem $ E.createSelfConversation lusr Nothing - conversationCreated zusr c + create :: Sem r ConversationResponse + create = do + c <- E.createSelfConversation lusr Nothing + conversationCreated lusr c createOne2OneConversation :: forall r. @@ -306,65 +320,66 @@ createOne2OneConversation :: Error TeamError, FederatorAccess, GundeckAccess, - TeamStore + Input UTCTime, + TeamStore, + P.TinyLog ] r => - UserId -> + Local UserId -> ConnId -> NewConvUnmanaged -> - Galley r ConversationResponse -createOne2OneConversation zusr zcon (NewConvUnmanaged j) = do - lusr <- qualifyLocal zusr + Sem r ConversationResponse +createOne2OneConversation lusr zcon (NewConvUnmanaged j) = do let allUsers = newConvMembers lusr j - other <- liftSem $ ensureOne (ulAll lusr allUsers) - liftSem . when (qUntagged lusr == other) $ + other <- ensureOne (ulAll lusr allUsers) + when (qUntagged lusr == other) $ throw . InvalidOp $ One2OneConv mtid <- case newConvTeam j of Just ti - | cnvManaged ti -> liftSem $ throw NoManagedTeamConv + | cnvManaged ti -> throw NoManagedTeamConv | otherwise -> do foldQualified lusr - (\lother -> checkBindingTeamPermissions lusr lother (cnvTeamId ti)) + (\lother -> checkBindingTeamPermissions lother (cnvTeamId ti)) (const (pure Nothing)) other Nothing -> ensureConnected lusr allUsers $> Nothing - n <- liftSem $ rangeCheckedMaybe (newConvName j) + n <- rangeCheckedMaybe (newConvName j) foldQualified lusr (createLegacyOne2OneConversationUnchecked lusr zcon n mtid) (createOne2OneConversationUnchecked lusr zcon n mtid . qUntagged) other where - verifyMembership :: TeamId -> UserId -> Galley r () + verifyMembership :: TeamId -> UserId -> Sem r () verifyMembership tid u = do - membership <- liftSem $ E.getTeamMember tid u - liftSem . when (isNothing membership) $ + membership <- E.getTeamMember tid u + when (isNothing membership) $ throw NoBindingTeamMembers checkBindingTeamPermissions :: - Local UserId -> Local UserId -> TeamId -> - Galley r (Maybe TeamId) - checkBindingTeamPermissions lusr lother tid = do - zusrMembership <- liftSem $ E.getTeamMember tid (tUnqualified lusr) + Sem r (Maybe TeamId) + checkBindingTeamPermissions lother tid = do + zusrMembership <- E.getTeamMember tid (tUnqualified lusr) void $ permissionCheck CreateConversation zusrMembership - liftSem (E.getTeamBinding tid) >>= \case + E.getTeamBinding tid >>= \case Just Binding -> do verifyMembership tid (tUnqualified lusr) verifyMembership tid (tUnqualified lother) pure (Just tid) - Just _ -> liftSem $ throw NotABindingTeamMember - Nothing -> liftSem $ throw TeamNotFound + Just _ -> throw NotABindingTeamMember + Nothing -> throw TeamNotFound createLegacyOne2OneConversationUnchecked :: Members '[ ConversationStore, - Error ActionError, Error InternalError, Error InvalidInput, FederatorAccess, - GundeckAccess + GundeckAccess, + Input UTCTime, + P.TinyLog ] r => Local UserId -> @@ -372,17 +387,17 @@ createLegacyOne2OneConversationUnchecked :: Maybe (Range 1 256 Text) -> Maybe TeamId -> Local UserId -> - Galley r ConversationResponse + Sem r ConversationResponse createLegacyOne2OneConversationUnchecked self zcon name mtid other = do lcnv <- localOne2OneConvId self other - mc <- liftSem $ E.getConversation (tUnqualified lcnv) + mc <- E.getConversation (tUnqualified lcnv) case mc of - Just c -> conversationExisted (tUnqualified self) c + Just c -> conversationExisted self c Nothing -> do (x, y) <- toUUIDs (tUnqualified self) (tUnqualified other) - c <- liftSem $ E.createLegacyOne2OneConversation self x y name mtid - notifyCreatedConversation Nothing (tUnqualified self) (Just zcon) c - conversationCreated (tUnqualified self) c + c <- E.createLegacyOne2OneConversation self x y name mtid + notifyCreatedConversation Nothing self (Just zcon) c + conversationCreated self c createOne2OneConversationUnchecked :: Members @@ -390,7 +405,9 @@ createOne2OneConversationUnchecked :: Error FederationError, Error InternalError, FederatorAccess, - GundeckAccess + GundeckAccess, + Input UTCTime, + P.TinyLog ] r => Local UserId -> @@ -398,7 +415,7 @@ createOne2OneConversationUnchecked :: Maybe (Range 1 256 Text) -> Maybe TeamId -> Qualified UserId -> - Galley r ConversationResponse + Sem r ConversationResponse createOne2OneConversationUnchecked self zcon name mtid other = do let create = foldQualified @@ -408,22 +425,30 @@ createOne2OneConversationUnchecked self zcon name mtid other = do create (one2OneConvId (qUntagged self) other) self zcon name mtid other createOne2OneConversationLocally :: - Members '[ConversationStore, Error InternalError, FederatorAccess, GundeckAccess] r => + Members + '[ ConversationStore, + Error InternalError, + FederatorAccess, + GundeckAccess, + Input UTCTime, + P.TinyLog + ] + r => Local ConvId -> Local UserId -> ConnId -> Maybe (Range 1 256 Text) -> Maybe TeamId -> Qualified UserId -> - Galley r ConversationResponse + Sem r ConversationResponse createOne2OneConversationLocally lcnv self zcon name mtid other = do - mc <- liftSem $ E.getConversation (tUnqualified lcnv) + mc <- E.getConversation (tUnqualified lcnv) case mc of - Just c -> conversationExisted (tUnqualified self) c + Just c -> conversationExisted self c Nothing -> do - c <- liftSem $ E.createOne2OneConversation (tUnqualified lcnv) self other name mtid - notifyCreatedConversation Nothing (tUnqualified self) (Just zcon) c - conversationCreated (tUnqualified self) c + c <- E.createOne2OneConversation (tUnqualified lcnv) self other name mtid + notifyCreatedConversation Nothing self (Just zcon) c + conversationCreated self c createOne2OneConversationRemotely :: Member (Error FederationError) r => @@ -433,10 +458,9 @@ createOne2OneConversationRemotely :: Maybe (Range 1 256 Text) -> Maybe TeamId -> Qualified UserId -> - Galley r ConversationResponse + Sem r ConversationResponse createOne2OneConversationRemotely _ _ _ _ _ _ = - liftSem $ - throw FederationNotImplemented + throw FederationNotImplemented createConnectConversation :: Members @@ -448,15 +472,16 @@ createConnectConversation :: Error InvalidInput, FederatorAccess, GundeckAccess, - MemberStore + Input UTCTime, + MemberStore, + P.TinyLog ] r => - UserId -> + Local UserId -> Maybe ConnId -> Connect -> - Galley r ConversationResponse -createConnectConversation usr conn j = do - lusr <- qualifyLocal usr + Sem r ConversationResponse +createConnectConversation lusr conn j = do foldQualified lusr (\lrcpt -> createLegacyConnectConversation lusr conn lrcpt j) @@ -468,10 +493,9 @@ createConnectConversationWithRemote :: Local UserId -> Maybe ConnId -> Remote UserId -> - Galley r ConversationResponse + Sem r ConversationResponse createConnectConversationWithRemote _ _ _ = - liftSem $ - throw FederationNotImplemented + throw FederationNotImplemented createLegacyConnectConversation :: Members @@ -482,42 +506,44 @@ createLegacyConnectConversation :: Error InternalError, FederatorAccess, GundeckAccess, - MemberStore + Input UTCTime, + MemberStore, + P.TinyLog ] r => Local UserId -> Maybe ConnId -> Local UserId -> Connect -> - Galley r ConversationResponse + Sem r ConversationResponse createLegacyConnectConversation lusr conn lrecipient j = do (x, y) <- toUUIDs (tUnqualified lusr) (tUnqualified lrecipient) - n <- liftSem $ rangeCheckedMaybe (cName j) - conv <- liftSem $ E.getConversation (Data.localOne2OneConvId x y) + n <- rangeCheckedMaybe (cName j) + conv <- E.getConversation (Data.localOne2OneConvId x y) maybe (create x y n) (update n) conv where create x y n = do - c <- liftSem $ E.createConnectConversation x y n - now <- liftIO getCurrentTime + c <- E.createConnectConversation x y n + now <- input let lcid = qualifyAs lusr (Data.convId c) e = Event ConvConnect (qUntagged lcid) (qUntagged lusr) now (EdConnect j) - notifyCreatedConversation Nothing (tUnqualified lusr) conn c + notifyCreatedConversation Nothing lusr conn c for_ (newPushLocal ListComplete (tUnqualified lusr) (ConvEvent e) (recipient <$> Data.convLocalMembers c)) $ \p -> - liftSem . E.push1 $ + E.push1 $ p & pushRoute .~ RouteDirect & pushConn .~ conn - conversationCreated (tUnqualified lusr) c + conversationCreated lusr c update n conv = do let mems = Data.convLocalMembers conv - in conversationExisted (tUnqualified lusr) + in conversationExisted lusr =<< if | (tUnqualified lusr) `isMember` mems -> -- we already were in the conversation, maybe also other connect n conv | otherwise -> do - lcid <- qualifyLocal (Data.convId conv) - mm <- liftSem $ E.createMember lcid lusr + let lcid = qualifyAs lusr (Data.convId conv) + mm <- E.createMember lcid lusr let conv' = conv { Data.convLocalMembers = Data.convLocalMembers conv <> toList mm @@ -528,23 +554,22 @@ createLegacyConnectConversation lusr conn lrecipient j = do connect n conv' else do -- we were not in the conversation, but someone else - conv'' <- acceptOne2One (tUnqualified lusr) conv' conn + conv'' <- acceptOne2One lusr conv' conn if Data.convType conv'' == ConnectConv then connect n conv'' else return conv'' connect n conv | Data.convType conv == ConnectConv = do - localDomain <- viewFederationDomain - let qconv = Qualified (Data.convId conv) localDomain + let lcnv = qualifyAs lusr (Data.convId conv) n' <- case n of - Just x -> liftSem $ do + Just x -> do E.setConversationName (Data.convId conv) x return . Just $ fromRange x Nothing -> return $ Data.convName conv - t <- liftIO getCurrentTime - let e = Event ConvConnect qconv (qUntagged lusr) t (EdConnect j) + t <- input + let e = Event ConvConnect (qUntagged lcnv) (qUntagged lusr) t (EdConnect j) for_ (newPushLocal ListComplete (tUnqualified lusr) (ConvEvent e) (recipient <$> Data.convLocalMembers conv)) $ \p -> - liftSem . E.push1 $ + E.push1 $ p & pushRoute .~ RouteDirect & pushConn .~ conn @@ -555,18 +580,18 @@ createLegacyConnectConversation lusr conn lrecipient j = do -- Helpers conversationCreated :: - Member (Error InternalError) r => - UserId -> + Members '[Error InternalError, P.TinyLog] r => + Local UserId -> Data.Conversation -> - Galley r ConversationResponse -conversationCreated usr cnv = Created <$> conversationView usr cnv + Sem r ConversationResponse +conversationCreated lusr cnv = Created <$> conversationView lusr cnv conversationExisted :: - Member (Error InternalError) r => - UserId -> + Members '[Error InternalError, P.TinyLog] r => + Local UserId -> Data.Conversation -> - Galley r ConversationResponse -conversationExisted usr cnv = Existed <$> conversationView usr cnv + Sem r ConversationResponse +conversationExisted lusr cnv = Existed <$> conversationView lusr cnv handleConversationResponse :: ConversationResponse -> Response handleConversationResponse = \case @@ -574,34 +599,32 @@ handleConversationResponse = \case Existed cnv -> json cnv & setStatus status200 . location (qUnqualified . cnvQualifiedId $ cnv) notifyCreatedConversation :: - Members '[Error InternalError, FederatorAccess, GundeckAccess] r => + Members '[Error InternalError, FederatorAccess, GundeckAccess, Input UTCTime, P.TinyLog] r => Maybe UTCTime -> - UserId -> + Local UserId -> Maybe ConnId -> Data.Conversation -> - Galley r () -notifyCreatedConversation dtime usr conn c = do - localDomain <- viewFederationDomain - now <- maybe (liftIO getCurrentTime) pure dtime + Sem r () +notifyCreatedConversation dtime lusr conn c = do + now <- maybe (input) pure dtime -- FUTUREWORK: Handle failures in notifying so it does not abort half way -- through (either when notifying remotes or locals) -- -- Ask remote server to store conversation membership and notify remote users -- of being added to a conversation - registerRemoteConversationMemberships now localDomain c + registerRemoteConversationMemberships now (tDomain lusr) c -- Notify local users - liftSem . E.push =<< mapM (toPush localDomain now) (Data.convLocalMembers c) + E.push =<< mapM (toPush now) (Data.convLocalMembers c) where route | Data.convType c == RegularConv = RouteAny | otherwise = RouteDirect - toPush dom t m = do - let qconv = Qualified (Data.convId c) dom - qusr = Qualified usr dom - c' <- conversationView (lmId m) c - let e = Event ConvCreate qconv qusr t (EdConversation c') + toPush t m = do + let lconv = qualifyAs lusr (Data.convId c) + c' <- conversationView (qualifyAs lusr (lmId m)) c + let e = Event ConvCreate (qUntagged lconv) (qUntagged lusr) t (EdConversation c') return $ - newPushLocal1 ListComplete usr (ConvEvent e) (list1 (recipient m) []) + newPushLocal1 ListComplete (tUnqualified lusr) (ConvEvent e) (list1 (recipient m) []) & pushConn .~ conn & pushRoute .~ route @@ -609,7 +632,7 @@ localOne2OneConvId :: Member (Error InvalidInput) r => Local UserId -> Local UserId -> - Galley r (Local ConvId) + Sem r (Local ConvId) localOne2OneConvId self other = do (x, y) <- toUUIDs (tUnqualified self) (tUnqualified other) pure . qualifyAs self $ Data.localOne2OneConvId x y @@ -618,10 +641,10 @@ toUUIDs :: Member (Error InvalidInput) r => UserId -> UserId -> - Galley r (U.UUID U.V4, U.UUID U.V4) + Sem r (U.UUID U.V4, U.UUID U.V4) toUUIDs a b = do - a' <- U.fromUUID (toUUID a) & note InvalidUUID4 & liftSem - b' <- U.fromUUID (toUUID b) & note InvalidUUID4 & liftSem + a' <- U.fromUUID (toUUID a) & note InvalidUUID4 + b' <- U.fromUUID (toUUID b) & note InvalidUUID4 return (a', b') accessRole :: NewConv -> AccessRole diff --git a/services/galley/src/Galley/API/CustomBackend.hs b/services/galley/src/Galley/API/CustomBackend.hs index 52cfd656b5d..ebcff2b55e2 100644 --- a/services/galley/src/Galley/API/CustomBackend.hs +++ b/services/galley/src/Galley/API/CustomBackend.hs @@ -25,8 +25,8 @@ where import Data.Domain (Domain) import Galley.API.Error import Galley.API.Util -import Galley.App import Galley.Effects.CustomBackendStore +import Galley.Effects.WaiRoutes import Galley.Types import Imports hiding ((\\)) import Network.HTTP.Types @@ -46,33 +46,32 @@ getCustomBackendByDomainH :: ] r => Domain ::: JSON -> - Galley r Response + Sem r Response getCustomBackendByDomainH (domain ::: _) = json <$> getCustomBackendByDomain domain getCustomBackendByDomain :: Members '[CustomBackendStore, Error CustomBackendError] r => Domain -> - Galley r Public.CustomBackend + Sem r Public.CustomBackend getCustomBackendByDomain domain = - liftSem $ - getCustomBackend domain >>= \case - Nothing -> throw (CustomBackendNotFound domain) - Just customBackend -> pure customBackend + getCustomBackend domain >>= \case + Nothing -> throw (CustomBackendNotFound domain) + Just customBackend -> pure customBackend -- INTERNAL ------------------------------------------------------------------- internalPutCustomBackendByDomainH :: - Members '[CustomBackendStore, Error InvalidInput] r => + Members '[CustomBackendStore, WaiRoutes] r => Domain ::: JsonRequest CustomBackend -> - Galley r Response + Sem r Response internalPutCustomBackendByDomainH (domain ::: req) = do customBackend <- fromJsonBody req -- simple enough to not need a separate function - liftSem $ setCustomBackend domain customBackend + setCustomBackend domain customBackend pure (empty & setStatus status201) -internalDeleteCustomBackendByDomainH :: Member CustomBackendStore r => Domain ::: JSON -> Galley r Response +internalDeleteCustomBackendByDomainH :: Member CustomBackendStore r => Domain ::: JSON -> Sem r Response internalDeleteCustomBackendByDomainH (domain ::: _) = do - liftSem $ deleteCustomBackend domain + deleteCustomBackend domain pure (empty & setStatus status200) diff --git a/services/galley/src/Galley/API/Error.hs b/services/galley/src/Galley/API/Error.hs index ab555dcff61..34c6ec0d3c8 100644 --- a/services/galley/src/Galley/API/Error.hs +++ b/services/galley/src/Galley/API/Error.hs @@ -218,12 +218,13 @@ instance APIError ClientError where toWai UnknownClient = errorDescriptionTypeToWai @UnknownClient throwED :: + forall e code label desc r a. ( e ~ ErrorDescription code label desc, KnownSymbol desc, Member (P.Error e) r ) => Sem r a -throwED = P.throw mkErrorDescription +throwED = P.throw @e mkErrorDescription noteED :: forall e code label desc r a. diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index 348bec3dec9..f1527638646 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -18,7 +18,6 @@ module Galley.API.Federation where import Brig.Types.Connection (Relation (Accepted)) import Control.Lens (itraversed, (<.>)) -import Control.Monad.Trans.Maybe (runMaybeT) import Data.ByteString.Conversion (toByteString') import Data.Containers.ListUtils (nubOrd) import Data.Domain (Domain) @@ -31,6 +30,7 @@ import Data.Qualified import Data.Range (Range (fromRange)) import qualified Data.Set as Set import qualified Data.Text.Lazy as LT +import Data.Time.Clock import Galley.API.Action import Galley.API.Error import qualified Galley.API.Mapping as Mapping @@ -41,11 +41,16 @@ import qualified Galley.Data.Conversation as Data import Galley.Effects import qualified Galley.Effects.BrigAccess as E import qualified Galley.Effects.ConversationStore as E +import qualified Galley.Effects.FireAndForget as E import qualified Galley.Effects.MemberStore as E +import Galley.Options import Galley.Types.Conversations.Members import Galley.Types.UserList (UserList (UserList)) import Imports -import Polysemy.Error (Error, throw) +import Polysemy +import Polysemy.Error +import Polysemy.Input +import qualified Polysemy.TinyLog as P import Servant (ServerT) import Servant.API.Generic (ToServantApi) import Servant.Server.Generic (genericServerT) @@ -57,13 +62,12 @@ import qualified Wire.API.Conversation.Role as Public import Wire.API.Event.Conversation import Wire.API.Federation.API.Common (EmptyResponse (..)) import qualified Wire.API.Federation.API.Galley as F -import Wire.API.Federation.Client import Wire.API.Routes.Internal.Brig.Connection import Wire.API.Routes.Public.Galley.Responses import Wire.API.ServantProto import Wire.API.User.Client (userClientMap) -federationSitemap :: ServerT (ToServantApi F.Api) (Galley GalleyEffects) +federationSitemap :: ServerT (ToServantApi F.Api) (Sem GalleyEffects) federationSitemap = genericServerT $ F.Api @@ -77,10 +81,10 @@ federationSitemap = } onConversationCreated :: - Members '[BrigAccess, GundeckAccess, ExternalAccess, MemberStore] r => + Members '[BrigAccess, GundeckAccess, ExternalAccess, Input (Local ()), MemberStore, P.TinyLog] r => Domain -> F.NewRemoteConversation ConvId -> - Galley r () + Sem r () onConversationCreated domain rc = do let qrc = fmap (toRemoteUnsafe domain) rc loc <- qualifyLocal () @@ -112,20 +116,19 @@ onConversationCreated domain rc = do (qUntagged (F.rcRemoteOrigUserId qrcConnected)) (F.rcTime qrcConnected) (EdConversation c) - pushConversationEvent Nothing event [qUnqualified . Public.memId $ mem] [] + pushConversationEvent Nothing event (qualifyAs loc [qUnqualified . Public.memId $ mem]) [] getConversations :: - Member ConversationStore r => + Members '[ConversationStore, Input (Local ())] r => Domain -> F.GetConversationsRequest -> - Galley r F.GetConversationsResponse + Sem r F.GetConversationsResponse getConversations domain (F.GetConversationsRequest uid cids) = do let ruid = toRemoteUnsafe domain uid - localDomain <- viewFederationDomain - liftSem $ - F.GetConversationsResponse - . mapMaybe (Mapping.conversationToRemote localDomain ruid) - <$> E.getConversations cids + loc <- qualifyLocal () + F.GetConversationsResponse + . mapMaybe (Mapping.conversationToRemote (tDomain loc) ruid) + <$> E.getConversations cids getLocalUsers :: Domain -> NonEmpty (Qualified UserId) -> [UserId] getLocalUsers localDomain = map qUnqualified . filter ((== localDomain) . qDomain) . toList @@ -133,12 +136,19 @@ getLocalUsers localDomain = map qUnqualified . filter ((== localDomain) . qDomai -- | Update the local database with information on conversation members joining -- or leaving. Finally, push out notifications to local users. onConversationUpdated :: - Members '[BrigAccess, GundeckAccess, ExternalAccess, MemberStore] r => + Members + '[ BrigAccess, + GundeckAccess, + ExternalAccess, + Input (Local ()), + MemberStore, + P.TinyLog + ] + r => Domain -> F.ConversationUpdate -> - Galley r () + Sem r () onConversationUpdated requestingDomain cu = do - localDomain <- viewFederationDomain loc <- qualifyLocal () let rconvId = toRemoteUnsafe requestingDomain (F.cuConvId cu) qconvId = qUntagged rconvId @@ -147,8 +157,7 @@ onConversationUpdated requestingDomain cu = do -- the conversation (from our point of view), to prevent spam from the remote -- backend. See also the comment below. (presentUsers, allUsersArePresent) <- - liftSem $ - E.selectRemoteMembers (F.cuAlreadyPresentUsers cu) rconvId + E.selectRemoteMembers (F.cuAlreadyPresentUsers cu) rconvId -- Perform action, and determine extra notification targets. -- @@ -166,8 +175,8 @@ onConversationUpdated requestingDomain cu = do case allAddedUsers of [] -> pure (Nothing, []) -- If no users get added, its like no action was performed. (u : us) -> pure (Just $ ConversationActionAddMembers (u :| us) role, addedLocalUsers) - ConversationActionRemoveMembers toRemove -> liftSem $ do - let localUsers = getLocalUsers localDomain toRemove + ConversationActionRemoveMembers toRemove -> do + let localUsers = getLocalUsers (tDomain loc) toRemove E.deleteMembersInRemoteConversation rconvId localUsers pure (Just $ F.cuAction cu, []) ConversationActionRename _ -> pure (Just $ F.cuAction cu, []) @@ -175,12 +184,12 @@ onConversationUpdated requestingDomain cu = do ConversationActionMemberUpdate _ _ -> pure (Just $ F.cuAction cu, []) ConversationActionReceiptModeUpdate _ -> pure (Just $ F.cuAction cu, []) ConversationActionAccessUpdate _ -> pure (Just $ F.cuAction cu, []) - ConversationActionDelete -> liftSem $ do + ConversationActionDelete -> do E.deleteMembersInRemoteConversation rconvId presentUsers pure (Just $ F.cuAction cu, []) unless allUsersArePresent $ - Log.warn $ + P.warn $ Log.field "conversation" (toByteString' (F.cuConvId cu)) . Log.field "domain" (toByteString' requestingDomain) . Log.msg @@ -195,16 +204,16 @@ onConversationUpdated requestingDomain cu = do targets = nubOrd $ presentUsers <> extraTargets -- FUTUREWORK: support bots? - pushConversationEvent Nothing event targets [] + pushConversationEvent Nothing event (qualifyAs loc targets) [] addLocalUsersToRemoteConv :: - Members '[BrigAccess, MemberStore] r => + Members '[BrigAccess, MemberStore, P.TinyLog] r => Remote ConvId -> Qualified UserId -> [UserId] -> - Galley r (Set UserId) + Sem r (Set UserId) addLocalUsersToRemoteConv remoteConvId qAdder localUsers = do - connStatus <- liftSem $ E.getConnections localUsers (Just [qAdder]) (Just Accepted) + connStatus <- E.getConnections localUsers (Just [qAdder]) (Just Accepted) let localUserIdsSet = Set.fromList localUsers connected = Set.fromList $ fmap csv2From connStatus unconnected = Set.difference localUserIdsSet connected @@ -213,48 +222,40 @@ addLocalUsersToRemoteConv remoteConvId qAdder localUsers = do -- FUTUREWORK: Consider handling the discrepancy between the views of the -- conversation-owning backend and the local backend unless (Set.null unconnected) $ - Log.warn $ + P.warn $ Log.msg ("A remote user is trying to add unconnected local users to a remote conversation" :: Text) . Log.field "remote_user" (show qAdder) . Log.field "local_unconnected_users" (show unconnected) -- Update the local view of the remote conversation by adding only those local -- users that are connected to the adder - liftSem $ E.createMembersInRemoteConversation remoteConvId connectedList + E.createMembersInRemoteConversation remoteConvId connectedList pure connected -- FUTUREWORK: actually return errors as part of the response instead of throwing leaveConversation :: Members - '[ BotAccess, - BrigAccess, - CodeStore, - ConversationStore, + '[ ConversationStore, Error ActionError, Error ConversationError, - Error FederationError, Error InvalidInput, - Error TeamError, ExternalAccess, FederatorAccess, - FireAndForget, GundeckAccess, - LegalHoldStore, - MemberStore, - TeamStore + Input (Local ()), + Input UTCTime, + MemberStore ] r => Domain -> F.LeaveConversationRequest -> - Galley r F.LeaveConversationResponse + Sem r F.LeaveConversationResponse leaveConversation requestingDomain lc = do let leaver = Qualified (F.lcLeaver lc) requestingDomain lcnv <- qualifyLocal (F.lcConvId lc) - fmap - ( F.LeaveConversationResponse - . maybe (Left RemoveFromConversationErrorUnchanged) Right - ) - . runMaybeT + fmap F.LeaveConversationResponse + . runError + . mapError @NoChanges (const RemoveFromConversationErrorUnchanged) . void . updateLocalConversation lcnv leaver Nothing . ConversationLeave @@ -264,10 +265,10 @@ leaveConversation requestingDomain lc = do -- FUTUREWORK: report errors to the originating backend -- FUTUREWORK: error handling for missing / mismatched clients onMessageSent :: - Members '[BotAccess, GundeckAccess, ExternalAccess, MemberStore] r => + Members '[GundeckAccess, ExternalAccess, MemberStore, Input (Local ()), P.TinyLog] r => Domain -> F.RemoteMessage ConvId -> - Galley r () + Sem r () onMessageSent domain rmUnqualified = do let rm = fmap (toRemoteUnsafe domain) rmUnqualified convId = qUntagged $ F.rmConversation rm @@ -281,10 +282,9 @@ onMessageSent domain rmUnqualified = do recipientMap = userClientMap $ F.rmRecipients rm msgs = toMapOf (itraversed <.> itraversed) recipientMap (members, allMembers) <- - liftSem $ - E.selectRemoteMembers (Map.keys recipientMap) (F.rmConversation rm) + E.selectRemoteMembers (Map.keys recipientMap) (F.rmConversation rm) unless allMembers $ - Log.warn $ + P.warn $ Log.field "conversation" (toByteString' (qUnqualified convId)) Log.~~ Log.field "domain" (toByteString' (qDomain convId)) Log.~~ Log.msg @@ -305,7 +305,7 @@ onMessageSent domain rmUnqualified = do msgs where -- FUTUREWORK: https://wearezeta.atlassian.net/browse/SQCORE-875 - mkLocalMember :: UserId -> Galley r LocalMember + mkLocalMember :: UserId -> Sem r LocalMember mkLocalMember m = pure $ LocalMember @@ -317,27 +317,31 @@ onMessageSent domain rmUnqualified = do sendMessage :: Members - '[ BotAccess, - BrigAccess, + '[ BrigAccess, ClientStore, ConversationStore, Error InvalidInput, FederatorAccess, GundeckAccess, + Input (Local ()), + Input Opts, + Input UTCTime, ExternalAccess, MemberStore, - TeamStore + TeamStore, + P.TinyLog ] r => Domain -> F.MessageSendRequest -> - Galley r F.MessageSendResponse + Sem r F.MessageSendResponse sendMessage originDomain msr = do let sender = Qualified (F.msrSender msr) originDomain - msg <- either err pure (fromProto (fromBase64ByteString (F.msrRawMessage msr))) - F.MessageSendResponse <$> postQualifiedOtrMessage User sender Nothing (F.msrConvId msr) msg + msg <- either throwErr pure (fromProto (fromBase64ByteString (F.msrRawMessage msr))) + lcnv <- qualifyLocal (F.msrConvId msr) + F.MessageSendResponse <$> postQualifiedOtrMessage User sender Nothing lcnv msg where - err = liftSem . throw . InvalidPayload . LT.pack + throwErr = throw . InvalidPayload . LT.pack onUserDeleted :: Members @@ -346,22 +350,24 @@ onUserDeleted :: FireAndForget, ExternalAccess, GundeckAccess, + Input (Local ()), + Input UTCTime, MemberStore ] r => Domain -> F.UserDeletedConversationsNotification -> - Galley r EmptyResponse + Sem r EmptyResponse onUserDeleted origDomain udcn = do let deletedUser = toRemoteUnsafe origDomain (F.udcnUser udcn) untaggedDeletedUser = qUntagged deletedUser convIds = F.udcnConversations udcn - spawnMany $ + E.spawnMany $ fromRange convIds <&> \c -> do lc <- qualifyLocal c - mconv <- liftSem $ E.getConversation c - liftSem $ E.deleteMembers c (UserList [] [deletedUser]) + mconv <- E.getConversation c + E.deleteMembers c (UserList [] [deletedUser]) for_ mconv $ \conv -> do when (isRemoteMember deletedUser (Data.convRemoteMembers conv)) $ case Data.convType conv of diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index e37590085ea..5c5a555b927 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -40,7 +40,7 @@ import qualified Galley.API.Create as Create import qualified Galley.API.CustomBackend as CustomBackend import Galley.API.Error import Galley.API.LegalHold (getTeamLegalholdWhitelistedH, setTeamLegalholdWhitelistedH, unsetTeamLegalholdWhitelistedH) -import Galley.API.LegalHold.Conflicts (guardLegalholdPolicyConflicts) +import Galley.API.LegalHold.Conflicts import qualified Galley.API.One2One as One2One import qualified Galley.API.Query as Query import Galley.API.Teams (uncheckedDeleteTeamMember) @@ -60,7 +60,10 @@ import Galley.Effects.GundeckAccess import Galley.Effects.MemberStore import Galley.Effects.Paging import Galley.Effects.TeamStore +import Galley.Effects.WaiRoutes import qualified Galley.Intra.Push as Intra +import Galley.Monad +import Galley.Options import qualified Galley.Queue as Q import Galley.Types import Galley.Types.Bot (AddBot, RemoveBot) @@ -74,11 +77,14 @@ import Imports hiding (head) import Network.HTTP.Types (status200) import Network.Wai import Network.Wai.Predicate hiding (Error, err) -import qualified Network.Wai.Predicate as P -import Network.Wai.Routing hiding (route, toList) +import qualified Network.Wai.Predicate as Predicate +import Network.Wai.Routing hiding (App, route, toList) import Network.Wai.Utilities hiding (Error) import Network.Wai.Utilities.ZAuth +import Polysemy import Polysemy.Error +import Polysemy.Input +import qualified Polysemy.TinyLog as P import Servant.API hiding (JSON) import qualified Servant.API as Servant import Servant.API.Generic @@ -94,7 +100,7 @@ import qualified Wire.API.Federation.API.Galley as FedGalley import Wire.API.Federation.Client (FederationError) import Wire.API.Routes.MultiTablePaging (mtpHasMore, mtpPagingState, mtpResults) import Wire.API.Routes.MultiVerb (MultiVerb, RespondEmpty) -import Wire.API.Routes.Public (ZOptConn, ZUser) +import Wire.API.Routes.Public (ZLocalUser, ZOptConn) import Wire.API.Routes.Public.Galley (ConversationVerb) import qualified Wire.API.Team.Feature as Public @@ -194,7 +200,7 @@ data InternalApi routes = InternalApi routes :- Summary "Remove a user from their teams and conversations and erase their clients" - :> ZUser + :> ZLocalUser :> ZOptConn :> "i" :> "user" @@ -205,7 +211,7 @@ data InternalApi routes = InternalApi iConnect :: routes :- Summary "Create a connect conversation (deprecated)" - :> ZUser + :> ZLocalUser :> ZOptConn :> "i" :> "conversations" @@ -266,7 +272,7 @@ type IFeatureStatusDeprecatedPut featureName = :> ReqBody '[Servant.JSON] (Public.TeamFeatureStatus featureName) :> Put '[Servant.JSON] (Public.TeamFeatureStatus featureName) -servantSitemap :: ServerT ServantAPI (Galley GalleyEffects) +servantSitemap :: ServerT ServantAPI (Sem GalleyEffects) servantSitemap = genericServerT $ InternalApi @@ -275,7 +281,7 @@ servantSitemap = iTeamFeatureStatusSSOGet = iGetTeamFeature @'Public.TeamFeatureSSO Features.getSSOStatusInternal, iTeamFeatureStatusSSOPut = iPutTeamFeature @'Public.TeamFeatureSSO Features.setSSOStatusInternal, iTeamFeatureStatusLegalHoldGet = iGetTeamFeature @'Public.TeamFeatureLegalHold Features.getLegalholdStatusInternal, - iTeamFeatureStatusLegalHoldPut = iPutTeamFeature @'Public.TeamFeatureLegalHold Features.setLegalholdStatusInternal, + iTeamFeatureStatusLegalHoldPut = iPutTeamFeature @'Public.TeamFeatureLegalHold (Features.setLegalholdStatusInternal @InternalPaging), iTeamFeatureStatusSearchVisibilityGet = iGetTeamFeature @'Public.TeamFeatureSearchVisibility Features.getTeamSearchVisibilityAvailableInternal, iTeamFeatureStatusSearchVisibilityPut = iPutTeamFeature @'Public.TeamFeatureLegalHold Features.setTeamSearchVisibilityAvailableInternal, iTeamFeatureStatusSearchVisibilityDeprecatedGet = iGetTeamFeature @'Public.TeamFeatureSearchVisibility Features.getTeamSearchVisibilityAvailableInternal, @@ -313,9 +319,9 @@ iGetTeamFeature :: ] r ) => - (Features.GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus a)) -> + (Features.GetFeatureInternalParam -> Sem r (Public.TeamFeatureStatus a)) -> TeamId -> - Galley r (Public.TeamFeatureStatus a) + Sem r (Public.TeamFeatureStatus a) iGetTeamFeature getter = Features.getFeatureStatus @a getter DontDoAuth iPutTeamFeature :: @@ -329,19 +335,19 @@ iPutTeamFeature :: ] r ) => - (TeamId -> Public.TeamFeatureStatus a -> Galley r (Public.TeamFeatureStatus a)) -> + (TeamId -> Public.TeamFeatureStatus a -> Sem r (Public.TeamFeatureStatus a)) -> TeamId -> Public.TeamFeatureStatus a -> - Galley r (Public.TeamFeatureStatus a) + Sem r (Public.TeamFeatureStatus a) iPutTeamFeature setter = Features.setFeatureStatus @a setter DontDoAuth -sitemap :: Routes a (Galley GalleyEffects) () +sitemap :: Routes a (Sem GalleyEffects) () sitemap = do -- Conversation API (internal) ---------------------------------------- put "/i/conversations/:cnv/channel" (continue $ const (return empty)) $ zauthUserId - .&. (capture "cnv" :: HasCaptures r => Predicate r P.Error ConvId) + .&. (capture "cnv" :: HasCaptures r => Predicate r Predicate.Error ConvId) .&. request get "/i/conversations/:cnv/members/:usr" (continue Query.internalGetMemberH) $ @@ -508,83 +514,81 @@ rmUser :: ExternalAccess, FederatorAccess, GundeckAccess, + Input UTCTime, ListItems p1 ConvId, ListItems p1 (Remote ConvId), ListItems p2 TeamId, MemberStore, - TeamStore + TeamStore, + P.TinyLog ] r ) => - UserId -> + Local UserId -> Maybe ConnId -> - Galley r () -rmUser user conn = do + Sem r () +rmUser lusr conn = do let nRange1000 = toRange (Proxy @1000) :: Range 1 1000 Int32 - tids <- liftSem $ listTeams user Nothing maxBound + tids <- listTeams (tUnqualified lusr) Nothing maxBound leaveTeams tids - allConvIds <- Query.conversationIdsPageFrom user (GetPaginatedConversationIds Nothing nRange1000) - lusr <- qualifyLocal user - goConvPages lusr nRange1000 allConvIds + allConvIds <- Query.conversationIdsPageFrom lusr (GetPaginatedConversationIds Nothing nRange1000) + goConvPages nRange1000 allConvIds - liftSem $ deleteClients user + deleteClients (tUnqualified lusr) where - goConvPages :: Local UserId -> Range 1 1000 Int32 -> ConvIdsPage -> Galley r () - goConvPages lusr range page = do + goConvPages :: Range 1 1000 Int32 -> ConvIdsPage -> Sem r () + goConvPages range page = do let (localConvs, remoteConvs) = partitionQualified lusr (mtpResults page) leaveLocalConversations localConvs - for_ (rangedChunks remoteConvs) (leaveRemoteConversations lusr) + traverse_ leaveRemoteConversations (rangedChunks remoteConvs) when (mtpHasMore page) $ do let nextState = mtpPagingState page - usr = tUnqualified lusr nextQuery = GetPaginatedConversationIds (Just nextState) range - newCids <- Query.conversationIdsPageFrom usr nextQuery - goConvPages lusr range newCids + newCids <- Query.conversationIdsPageFrom lusr nextQuery + goConvPages range newCids leaveTeams page = for_ (pageItems page) $ \tid -> do mems <- getTeamMembersForFanout tid - uncheckedDeleteTeamMember user conn tid user mems - page' <- liftSem $ listTeams user (Just (pageState page)) maxBound + uncheckedDeleteTeamMember lusr conn tid (tUnqualified lusr) mems + page' <- listTeams @p2 (tUnqualified lusr) (Just (pageState page)) maxBound leaveTeams page' - leaveLocalConversations :: Member MemberStore r => [ConvId] -> Galley r () + leaveLocalConversations :: [ConvId] -> Sem r () leaveLocalConversations ids = do - localDomain <- viewFederationDomain - let qUser = Qualified user localDomain - cc <- liftSem $ getConversations ids - now <- liftIO getCurrentTime + let qUser = qUntagged lusr + cc <- getConversations ids + now <- input pp <- for cc $ \c -> case Data.convType c of SelfConv -> return Nothing - One2OneConv -> liftSem $ deleteMembers (Data.convId c) (UserList [user] []) $> Nothing - ConnectConv -> liftSem $ deleteMembers (Data.convId c) (UserList [user] []) $> Nothing + One2OneConv -> deleteMembers (Data.convId c) (UserList [tUnqualified lusr] []) $> Nothing + ConnectConv -> deleteMembers (Data.convId c) (UserList [tUnqualified lusr] []) $> Nothing RegularConv - | user `isMember` Data.convLocalMembers c -> do - liftSem $ deleteMembers (Data.convId c) (UserList [user] []) + | tUnqualified lusr `isMember` Data.convLocalMembers c -> do + deleteMembers (Data.convId c) (UserList [tUnqualified lusr] []) let e = Event MemberLeave - (Qualified (Data.convId c) localDomain) - (Qualified user localDomain) + (qUntagged (qualifyAs lusr (Data.convId c))) + (qUntagged lusr) now (EdMembersLeave (QualifiedUserIdList [qUser])) for_ (bucketRemote (fmap rmId (Data.convRemoteMembers c))) $ notifyRemoteMembers now qUser (Data.convId c) pure $ - Intra.newPushLocal ListComplete user (Intra.ConvEvent e) (Intra.recipient <$> Data.convLocalMembers c) + Intra.newPushLocal ListComplete (tUnqualified lusr) (Intra.ConvEvent e) (Intra.recipient <$> Data.convLocalMembers c) <&> set Intra.pushConn conn . set Intra.pushRoute Intra.RouteDirect | otherwise -> return Nothing for_ (maybeList1 (catMaybes pp)) - (liftSem . push) + (push) -- FUTUREWORK: This could be optimized to reduce the number of RPCs -- made. When a team is deleted the burst of RPCs created here could -- lead to performance issues. We should cover this in a performance -- test. - notifyRemoteMembers :: UTCTime -> Qualified UserId -> ConvId -> Remote [UserId] -> Galley r () + notifyRemoteMembers :: UTCTime -> Qualified UserId -> ConvId -> Remote [UserId] -> Sem r () notifyRemoteMembers now qUser cid remotes = do - localDomain <- viewFederationDomain let convUpdate = ConversationUpdate { cuTime = now, @@ -593,25 +597,25 @@ rmUser user conn = do cuAlreadyPresentUsers = tUnqualified remotes, cuAction = ConversationActionRemoveMembers (pure qUser) } - let rpc = FedGalley.onConversationUpdated FedGalley.clientRoutes localDomain convUpdate - liftSem (runFederatedEither remotes rpc) + let rpc = FedGalley.onConversationUpdated FedGalley.clientRoutes (tDomain lusr) convUpdate + runFederatedEither remotes rpc >>= logAndIgnoreError "Error in onConversationUpdated call" (qUnqualified qUser) - leaveRemoteConversations :: Local UserId -> Range 1 FedGalley.UserDeletedNotificationMaxConvs [Remote ConvId] -> Galley r () - leaveRemoteConversations lusr cids = do + leaveRemoteConversations :: Range 1 FedGalley.UserDeletedNotificationMaxConvs [Remote ConvId] -> Sem r () + leaveRemoteConversations cids = do for_ (bucketRemote (fromRange cids)) $ \remoteConvs -> do let userDelete = UserDeletedConversationsNotification (tUnqualified lusr) (unsafeRange (tUnqualified remoteConvs)) let rpc = FedGalley.onUserDeleted FedGalley.clientRoutes (tDomain lusr) userDelete - liftSem (runFederatedEither remoteConvs rpc) + runFederatedEither remoteConvs rpc >>= logAndIgnoreError "Error in onUserDeleted call" (tUnqualified lusr) -- FUTUREWORK: Add a retry mechanism if there are federation errrors. -- See https://wearezeta.atlassian.net/browse/SQCORE-1091 - logAndIgnoreError :: Text -> UserId -> Either FederationError a -> Galley r () + logAndIgnoreError :: Text -> UserId -> Either FederationError a -> Sem r () logAndIgnoreError message usr res = do case res of - Left federationError -> do - Log.err + Left federationError -> + P.err ( Log.msg ( "Federation error while notifying remote backends of a user deletion (Galley). " <> message @@ -622,12 +626,13 @@ rmUser user conn = do ) Right _ -> pure () -deleteLoop :: Galley r () -deleteLoop = liftGalley0 $ do +deleteLoop :: App () +deleteLoop = do q <- view deleteQueue safeForever "deleteLoop" $ do i@(TeamItem tid usr con) <- Q.pop q - interpretGalleyToGalley0 (Teams.uncheckedDeleteTeam usr con tid) + env <- ask + liftIO (evalGalley env (doDelete usr con tid)) `catchAny` someError q i where someError q i x = do @@ -637,7 +642,11 @@ deleteLoop = liftGalley0 $ do err (msg (val "delete queue is full, dropping item") ~~ "item" .= show i) liftIO $ threadDelay 1000000 -safeForever :: String -> Galley0 () -> Galley0 () + doDelete usr con tid = do + lusr <- qualifyLocal usr + Teams.uncheckedDeleteTeam lusr con tid + +safeForever :: String -> App () -> App () safeForever funName action = forever $ action `catchAny` \exc -> do @@ -648,14 +657,16 @@ guardLegalholdPolicyConflictsH :: Members '[ BrigAccess, Error LegalHoldError, - Error InvalidInput, - TeamStore + Input Opts, + TeamStore, + P.TinyLog, + WaiRoutes ] r => (JsonRequest GuardLegalholdPolicyConflicts ::: JSON) -> - Galley r Response + Sem r Response guardLegalholdPolicyConflictsH (req ::: _) = do glh <- fromJsonBody req - guardLegalholdPolicyConflicts (glhProtectee glh) (glhUserClients glh) - >>= either (const (liftSem (throw MissingLegalholdConsent))) pure + mapError @LegalholdConflicts (const MissingLegalholdConsent) $ + guardLegalholdPolicyConflicts (glhProtectee glh) (glhUserClients glh) pure $ Network.Wai.Utilities.setStatus status200 empty diff --git a/services/galley/src/Galley/API/LegalHold.hs b/services/galley/src/Galley/API/LegalHold.hs index 998ea8ed751..5bbe62a2362 100644 --- a/services/galley/src/Galley/API/LegalHold.hs +++ b/services/galley/src/Galley/API/LegalHold.hs @@ -44,24 +44,25 @@ import Data.LegalHold (UserLegalHoldStatus (..), defUserLegalHoldStatus) import Data.List.Split (chunksOf) import Data.Misc import Data.Proxy (Proxy (Proxy)) -import Data.Qualified (qUntagged) +import Data.Qualified import Data.Range (toRange) +import Data.Time.Clock import Galley.API.Error import Galley.API.Query (iterateConversations) import Galley.API.Update (removeMemberFromLocalConv) import Galley.API.Util -import Galley.App import Galley.Cassandra.Paging import qualified Galley.Data.Conversation as Data import Galley.Effects import Galley.Effects.BrigAccess +import Galley.Effects.FireAndForget import qualified Galley.Effects.LegalHoldStore as LegalHoldData import Galley.Effects.Paging import qualified Galley.Effects.TeamFeatureStore as TeamFeatures import Galley.Effects.TeamMemberStore import Galley.Effects.TeamStore +import Galley.Effects.WaiRoutes import qualified Galley.External.LegalHoldService as LHService -import qualified Galley.Options as Opts import Galley.Types (LocalMember, lmConvRoleName, lmId) import Galley.Types.Teams as Team import Imports @@ -70,7 +71,10 @@ import Network.HTTP.Types.Status (status201, status204) import Network.Wai import Network.Wai.Predicate hiding (Error, or, result, setStatus, _3) import Network.Wai.Utilities as Wai hiding (Error) +import Polysemy import Polysemy.Error +import Polysemy.Input +import qualified Polysemy.TinyLog as P import qualified System.Logger.Class as Log import Wire.API.Conversation (ConvType (..)) import Wire.API.Conversation.Role (roleNameWireAdmin) @@ -82,46 +86,45 @@ import Wire.API.Team.LegalHold (LegalholdProtectee (LegalholdPlusFederationNotIm import qualified Wire.API.Team.LegalHold as Public assertLegalHoldEnabledForTeam :: - Members '[Error LegalHoldError, Error NotATeamMember, LegalHoldStore, TeamFeatureStore] r => + Members '[Error LegalHoldError, LegalHoldStore, TeamStore, TeamFeatureStore] r => TeamId -> - Galley r () + Sem r () assertLegalHoldEnabledForTeam tid = unlessM (isLegalHoldEnabledForTeam tid) $ - liftSem $ throw LegalHoldNotEnabled + throw LegalHoldNotEnabled isLegalHoldEnabledForTeam :: - Members '[LegalHoldStore, TeamFeatureStore] r => + Members '[LegalHoldStore, TeamStore, TeamFeatureStore] r => TeamId -> - Galley r Bool + Sem r Bool isLegalHoldEnabledForTeam tid = do - view (options . Opts.optSettings . Opts.setFeatureFlags . flagLegalHold) >>= \case + getLegalHoldFlag >>= \case FeatureLegalHoldDisabledPermanently -> do pure False FeatureLegalHoldDisabledByDefault -> do statusValue <- - liftSem $ - Public.tfwoStatus <$$> TeamFeatures.getFeatureStatusNoConfig @'Public.TeamFeatureLegalHold tid + Public.tfwoStatus <$$> TeamFeatures.getFeatureStatusNoConfig @'Public.TeamFeatureLegalHold tid return $ case statusValue of Just Public.TeamFeatureEnabled -> True Just Public.TeamFeatureDisabled -> False Nothing -> False FeatureLegalHoldWhitelistTeamsAndImplicitConsent -> - liftSem $ LegalHoldData.isTeamLegalholdWhitelisted tid + LegalHoldData.isTeamLegalholdWhitelisted tid createSettingsH :: Members '[ Error ActionError, - Error InvalidInput, Error LegalHoldError, Error NotATeamMember, - Error TeamError, LegalHoldStore, TeamFeatureStore, - TeamStore + TeamStore, + P.TinyLog, + WaiRoutes ] r => UserId ::: TeamId ::: JsonRequest Public.NewLegalHoldService ::: JSON -> - Galley r Response + Sem r Response createSettingsH (zusr ::: tid ::: req ::: _) = do newService <- fromJsonBody req setStatus status201 . json <$> createSettings zusr tid newService @@ -129,40 +132,37 @@ createSettingsH (zusr ::: tid ::: req ::: _) = do createSettings :: Members '[ Error ActionError, - Error InvalidInput, Error LegalHoldError, Error NotATeamMember, - Error TeamError, LegalHoldStore, TeamFeatureStore, - TeamStore + TeamStore, + P.TinyLog ] r => UserId -> TeamId -> Public.NewLegalHoldService -> - Galley r Public.ViewLegalHoldService + Sem r Public.ViewLegalHoldService createSettings zusr tid newService = do assertLegalHoldEnabledForTeam tid - zusrMembership <- liftSem $ getTeamMember tid zusr + zusrMembership <- getTeamMember tid zusr -- let zothers = map (view userId) membs -- Log.debug $ -- Log.field "targets" (toByteString . show $ toByteString <$> zothers) -- . Log.field "action" (Log.val "LegalHold.createSettings") void $ permissionCheck ChangeLegalHoldTeamSettings zusrMembership (key :: ServiceKey, fpr :: Fingerprint Rsa) <- - LHService.validateServiceKey (newLegalHoldServiceKey newService) - >>= liftSem . note LegalHoldServiceInvalidKey + LegalHoldData.validateServiceKey (newLegalHoldServiceKey newService) + >>= note LegalHoldServiceInvalidKey LHService.checkLegalHoldServiceStatus fpr (newLegalHoldServiceUrl newService) let service = legalHoldService tid fpr newService key - liftSem $ LegalHoldData.createSettings service + LegalHoldData.createSettings service pure . viewLegalHoldService $ service getSettingsH :: Members '[ Error ActionError, - Error InvalidInput, - Error TeamError, Error NotATeamMember, LegalHoldStore, TeamFeatureStore, @@ -170,15 +170,13 @@ getSettingsH :: ] r => UserId ::: TeamId ::: JSON -> - Galley r Response + Sem r Response getSettingsH (zusr ::: tid ::: _) = do json <$> getSettings zusr tid getSettings :: Members '[ Error ActionError, - Error InvalidInput, - Error TeamError, Error NotATeamMember, LegalHoldStore, TeamFeatureStore, @@ -187,12 +185,12 @@ getSettings :: r => UserId -> TeamId -> - Galley r Public.ViewLegalHoldService + Sem r Public.ViewLegalHoldService getSettings zusr tid = do - zusrMembership <- liftSem $ getTeamMember tid zusr + zusrMembership <- getTeamMember tid zusr void $ permissionCheck (ViewTeamFeature Public.TeamFeatureLegalHold) zusrMembership isenabled <- isLegalHoldEnabledForTeam tid - mresult <- liftSem $ LegalHoldData.getSettings tid + mresult <- LegalHoldData.getSettings tid pure $ case (isenabled, mresult) of (False, _) -> Public.ViewLegalHoldServiceDisabled (True, Nothing) -> Public.ViewLegalHoldServiceNotConfigured @@ -216,22 +214,27 @@ removeSettingsH :: FederatorAccess, FireAndForget, GundeckAccess, + Input UTCTime, + Input (Local ()), LegalHoldStore, ListItems LegacyPaging ConvId, MemberStore, - TeamStore, TeamFeatureStore, - TeamMemberStore InternalPaging + TeamMemberStore InternalPaging, + TeamStore, + P.TinyLog, + WaiRoutes ] r => UserId ::: TeamId ::: JsonRequest Public.RemoveLegalHoldSettingsRequest ::: JSON -> - Galley r Response + Sem r Response removeSettingsH (zusr ::: tid ::: req ::: _) = do removeSettingsRequest <- fromJsonBody req - removeSettings zusr tid removeSettingsRequest + removeSettings @InternalPaging zusr tid removeSettingsRequest pure noContent removeSettings :: + forall p r. ( Paging p, Bounded (PagingBounds p TeamMember), Members @@ -251,38 +254,41 @@ removeSettings :: FederatorAccess, FireAndForget, GundeckAccess, + Input UTCTime, + Input (Local ()), LegalHoldStore, ListItems LegacyPaging ConvId, MemberStore, TeamFeatureStore, + TeamMemberStore p, TeamStore, - TeamMemberStore p + P.TinyLog ] r ) => UserId -> TeamId -> Public.RemoveLegalHoldSettingsRequest -> - Galley r () + Sem r () removeSettings zusr tid (Public.RemoveLegalHoldSettingsRequest mPassword) = do assertNotWhitelisting assertLegalHoldEnabledForTeam tid - zusrMembership <- liftSem $ getTeamMember tid zusr + zusrMembership <- getTeamMember tid zusr -- let zothers = map (view userId) membs -- Log.debug $ -- Log.field "targets" (toByteString . show $ toByteString <$> zothers) -- . Log.field "action" (Log.val "LegalHold.removeSettings") void $ permissionCheck ChangeLegalHoldTeamSettings zusrMembership ensureReAuthorised zusr mPassword - removeSettings' tid + removeSettings' @p tid where - assertNotWhitelisting :: Member (Error LegalHoldError) r => Galley r () + assertNotWhitelisting :: Sem r () assertNotWhitelisting = do - view (options . Opts.optSettings . Opts.setFeatureFlags . flagLegalHold) >>= \case + getLegalHoldFlag >>= \case FeatureLegalHoldDisabledPermanently -> pure () FeatureLegalHoldDisabledByDefault -> pure () - FeatureLegalHoldWhitelistTeamsAndImplicitConsent -> do - liftSem $ throw LegalHoldDisableUnimplemented + FeatureLegalHoldWhitelistTeamsAndImplicitConsent -> + throw LegalHoldDisableUnimplemented -- | Remove legal hold settings from team; also disabling for all users and removing LH devices removeSettings' :: @@ -306,53 +312,56 @@ removeSettings' :: FederatorAccess, FireAndForget, GundeckAccess, + Input UTCTime, + Input (Local ()), LegalHoldStore, ListItems LegacyPaging ConvId, MemberStore, + TeamMemberStore p, TeamStore, - TeamMemberStore p + P.TinyLog ] r ) => TeamId -> - Galley r () + Sem r () removeSettings' tid = withChunks - (\mps -> liftSem (listTeamMembers tid mps maxBound)) + (\mps -> listTeamMembers @p tid mps maxBound) action where - action :: [TeamMember] -> Galley r () + action :: [TeamMember] -> Sem r () action membs = do let zothers = map (view userId) membs let lhMembers = filter ((== UserLegalHoldEnabled) . view legalHoldStatus) membs - Log.debug $ + P.debug $ Log.field "targets" (toByteString . show $ toByteString <$> zothers) . Log.field "action" (Log.val "LegalHold.removeSettings'") spawnMany (map removeLHForUser lhMembers) - removeLHForUser :: TeamMember -> Galley r () + removeLHForUser :: TeamMember -> Sem r () removeLHForUser member = do - let uid = member ^. Team.userId - liftSem $ removeLegalHoldClientFromUser uid - LHService.removeLegalHold tid uid - changeLegalholdStatus tid uid (member ^. legalHoldStatus) UserLegalHoldDisabled -- (support for withdrawing consent is not planned yet.) + luid <- qualifyLocal (member ^. Team.userId) + removeLegalHoldClientFromUser (tUnqualified luid) + LHService.removeLegalHold tid (tUnqualified luid) + changeLegalholdStatus tid luid (member ^. legalHoldStatus) UserLegalHoldDisabled -- (support for withdrawing consent is not planned yet.) -- | Learn whether a user has LH enabled and fetch pre-keys. -- Note that this is accessible to ANY authenticated user, even ones outside the team getUserStatusH :: - Members '[Error InternalError, Error TeamError, LegalHoldStore, TeamStore] r => + Members '[Error InternalError, Error TeamError, LegalHoldStore, TeamStore, P.TinyLog] r => UserId ::: TeamId ::: UserId ::: JSON -> - Galley r Response + Sem r Response getUserStatusH (_zusr ::: tid ::: uid ::: _) = do json <$> getUserStatus tid uid getUserStatus :: forall r. - Members '[Error InternalError, Error TeamError, LegalHoldStore, TeamStore] r => + Members '[Error InternalError, Error TeamError, LegalHoldStore, TeamStore, P.TinyLog] r => TeamId -> UserId -> - Galley r Public.UserLegalHoldStatusResponse + Sem r Public.UserLegalHoldStatusResponse getUserStatus tid uid = do - teamMember <- liftSem $ note TeamMemberNotFound =<< getTeamMember tid uid + teamMember <- note TeamMemberNotFound =<< getTeamMember tid uid let status = view legalHoldStatus teamMember (mlk, lcid) <- case status of UserLegalHoldNoConsent -> pure (Nothing, Nothing) @@ -361,16 +370,16 @@ getUserStatus tid uid = do UserLegalHoldEnabled -> makeResponseDetails pure $ UserLegalHoldStatusResponse status mlk lcid where - makeResponseDetails :: Galley r (Maybe LastPrekey, Maybe ClientId) + makeResponseDetails :: Sem r (Maybe LastPrekey, Maybe ClientId) makeResponseDetails = do - mLastKey <- liftSem $ fmap snd <$> LegalHoldData.selectPendingPrekeys uid + mLastKey <- fmap snd <$> LegalHoldData.selectPendingPrekeys uid lastKey <- case mLastKey of Nothing -> do - Log.err . Log.msg $ + P.err . Log.msg $ "expected to find a prekey for user: " <> toByteString' uid <> " but none was found" - liftSem $ throw NoPrekeyForUser + throw NoPrekeyForUser Just lstKey -> pure lstKey let clientId = clientIdFromPrekey . unpackLastPrekey $ lastKey pure (Just lastKey, Just clientId) @@ -380,31 +389,30 @@ getUserStatus tid uid = do -- out). grantConsentH :: Members - '[ BotAccess, - BrigAccess, - CodeStore, + '[ BrigAccess, ConversationStore, Error ActionError, Error InvalidInput, Error ConversationError, - Error FederationError, Error LegalHoldError, - Error NotATeamMember, Error TeamError, ExternalAccess, FederatorAccess, - FireAndForget, GundeckAccess, + Input UTCTime, + Input (Local ()), LegalHoldStore, ListItems LegacyPaging ConvId, MemberStore, - TeamStore + TeamStore, + P.TinyLog ] r => UserId ::: TeamId ::: JSON -> - Galley r Response + Sem r Response grantConsentH (zusr ::: tid ::: _) = do - grantConsent zusr tid >>= \case + lusr <- qualifyLocal zusr + grantConsent lusr tid >>= \case GrantConsentSuccess -> pure $ empty & setStatus status201 GrantConsentAlreadyGranted -> pure $ empty & setStatus status204 @@ -414,38 +422,34 @@ data GrantConsentResult grantConsent :: Members - '[ BotAccess, - BrigAccess, - CodeStore, + '[ BrigAccess, ConversationStore, Error ActionError, Error InvalidInput, Error ConversationError, - Error FederationError, Error LegalHoldError, - Error NotATeamMember, Error TeamError, ExternalAccess, FederatorAccess, - FireAndForget, GundeckAccess, + Input UTCTime, LegalHoldStore, ListItems LegacyPaging ConvId, MemberStore, - TeamStore + TeamStore, + P.TinyLog ] r => - UserId -> + Local UserId -> TeamId -> - Galley r GrantConsentResult -grantConsent zusr tid = do + Sem r GrantConsentResult +grantConsent lusr tid = do userLHStatus <- - liftSem $ - note TeamMemberNotFound - =<< fmap (view legalHoldStatus) <$> getTeamMember tid zusr + note TeamMemberNotFound + =<< fmap (view legalHoldStatus) <$> getTeamMember tid (tUnqualified lusr) case userLHStatus of lhs@UserLegalHoldNoConsent -> - changeLegalholdStatus tid zusr lhs UserLegalHoldDisabled $> GrantConsentSuccess + changeLegalholdStatus tid lusr lhs UserLegalHoldDisabled $> GrantConsentSuccess UserLegalHoldEnabled -> pure GrantConsentAlreadyGranted UserLegalHoldPending -> pure GrantConsentAlreadyGranted UserLegalHoldDisabled -> pure GrantConsentAlreadyGranted @@ -453,32 +457,32 @@ grantConsent zusr tid = do -- | Request to provision a device on the legal hold service for a user requestDeviceH :: Members - '[ BotAccess, - BrigAccess, - CodeStore, + '[ BrigAccess, ConversationStore, Error ActionError, Error InvalidInput, Error ConversationError, - Error FederationError, Error LegalHoldError, - Error NotATeamMember, Error TeamError, + Error NotATeamMember, ExternalAccess, FederatorAccess, - FireAndForget, GundeckAccess, + Input UTCTime, + Input (Local ()), LegalHoldStore, ListItems LegacyPaging ConvId, MemberStore, TeamFeatureStore, - TeamStore + TeamStore, + P.TinyLog ] r => UserId ::: TeamId ::: UserId ::: JSON -> - Galley r Response + Sem r Response requestDeviceH (zusr ::: tid ::: uid ::: _) = do - requestDevice zusr tid uid <&> \case + luid <- qualifyLocal uid + requestDevice zusr tid luid <&> \case RequestDeviceSuccess -> empty & setStatus status201 RequestDeviceAlreadyPending -> empty & setStatus status204 @@ -489,45 +493,43 @@ data RequestDeviceResult requestDevice :: forall r. Members - '[ BotAccess, - BrigAccess, - CodeStore, + '[ BrigAccess, ConversationStore, Error ActionError, Error InvalidInput, Error ConversationError, - Error FederationError, Error LegalHoldError, - Error NotATeamMember, Error TeamError, + Error NotATeamMember, ExternalAccess, FederatorAccess, - FireAndForget, GundeckAccess, + Input UTCTime, LegalHoldStore, ListItems LegacyPaging ConvId, MemberStore, TeamFeatureStore, - TeamStore + TeamStore, + P.TinyLog ] r => UserId -> TeamId -> - UserId -> - Galley r RequestDeviceResult -requestDevice zusr tid uid = do + Local UserId -> + Sem r RequestDeviceResult +requestDevice zusr tid luid = do assertLegalHoldEnabledForTeam tid - Log.debug $ - Log.field "targets" (toByteString uid) + P.debug $ + Log.field "targets" (toByteString (tUnqualified luid)) . Log.field "action" (Log.val "LegalHold.requestDevice") - zusrMembership <- liftSem $ getTeamMember tid zusr + zusrMembership <- getTeamMember tid zusr void $ permissionCheck ChangeLegalHoldUserSettings zusrMembership - member <- liftSem $ note TeamMemberNotFound =<< getTeamMember tid uid + member <- note TeamMemberNotFound =<< getTeamMember tid (tUnqualified luid) case member ^. legalHoldStatus of - UserLegalHoldEnabled -> liftSem $ throw UserLegalHoldAlreadyEnabled + UserLegalHoldEnabled -> throw UserLegalHoldAlreadyEnabled lhs@UserLegalHoldPending -> RequestDeviceAlreadyPending <$ provisionLHDevice lhs lhs@UserLegalHoldDisabled -> RequestDeviceSuccess <$ provisionLHDevice lhs - UserLegalHoldNoConsent -> liftSem $ throw NoUserLegalHoldConsent + UserLegalHoldNoConsent -> throw NoUserLegalHoldConsent where -- Wire's LH service that galley is usually calling here is idempotent in device creation, -- ie. it returns the existing device on multiple calls to `/init`, like here: @@ -536,18 +538,18 @@ requestDevice zusr tid uid = do -- This will still work if the LH service creates two new device on two consecutive calls -- to `/init`, but there may be race conditions, eg. when updating and enabling a pending -- device at (almost) the same time. - provisionLHDevice :: UserLegalHoldStatus -> Galley r () + provisionLHDevice :: UserLegalHoldStatus -> Sem r () provisionLHDevice userLHStatus = do (lastPrekey', prekeys) <- requestDeviceFromService -- We don't distinguish the last key here; brig will do so when the device is added - liftSem $ LegalHoldData.insertPendingPrekeys uid (unpackLastPrekey lastPrekey' : prekeys) - changeLegalholdStatus tid uid userLHStatus UserLegalHoldPending - liftSem $ notifyClientsAboutLegalHoldRequest zusr uid lastPrekey' + LegalHoldData.insertPendingPrekeys (tUnqualified luid) (unpackLastPrekey lastPrekey' : prekeys) + changeLegalholdStatus tid luid userLHStatus UserLegalHoldPending + notifyClientsAboutLegalHoldRequest zusr (tUnqualified luid) lastPrekey' - requestDeviceFromService :: Galley r (LastPrekey, [Prekey]) + requestDeviceFromService :: Sem r (LastPrekey, [Prekey]) requestDeviceFromService = do - liftSem $ LegalHoldData.dropPendingPrekeys uid - lhDevice <- LHService.requestNewDevice tid uid + LegalHoldData.dropPendingPrekeys (tUnqualified luid) + lhDevice <- LHService.requestNewDevice tid (tUnqualified luid) let NewLegalHoldClient prekeys lastKey = lhDevice return (lastKey, prekeys) @@ -558,99 +560,95 @@ requestDevice zusr tid uid = do -- since they are replaced if needed when registering new LH devices. approveDeviceH :: Members - '[ BotAccess, - BrigAccess, - CodeStore, + '[ BrigAccess, ConversationStore, Error ActionError, Error InvalidInput, Error AuthenticationError, Error ConversationError, - Error FederationError, Error LegalHoldError, Error NotATeamMember, - Error TeamError, ExternalAccess, FederatorAccess, - FireAndForget, GundeckAccess, + Input UTCTime, + Input (Local ()), LegalHoldStore, ListItems LegacyPaging ConvId, MemberStore, TeamFeatureStore, - TeamStore + TeamStore, + P.TinyLog, + WaiRoutes ] r => UserId ::: TeamId ::: UserId ::: ConnId ::: JsonRequest Public.ApproveLegalHoldForUserRequest ::: JSON -> - Galley r Response + Sem r Response approveDeviceH (zusr ::: tid ::: uid ::: connId ::: req ::: _) = do + luid <- qualifyLocal uid approve <- fromJsonBody req - approveDevice zusr tid uid connId approve + approveDevice zusr tid luid connId approve pure empty approveDevice :: Members - '[ BotAccess, - BrigAccess, - CodeStore, + '[ BrigAccess, ConversationStore, Error ActionError, Error InvalidInput, Error AuthenticationError, Error ConversationError, - Error FederationError, Error LegalHoldError, Error NotATeamMember, - Error TeamError, ExternalAccess, FederatorAccess, - FireAndForget, GundeckAccess, + Input UTCTime, LegalHoldStore, ListItems LegacyPaging ConvId, MemberStore, TeamFeatureStore, - TeamStore + TeamStore, + P.TinyLog ] r => UserId -> TeamId -> - UserId -> + Local UserId -> ConnId -> Public.ApproveLegalHoldForUserRequest -> - Galley r () -approveDevice zusr tid uid connId (Public.ApproveLegalHoldForUserRequest mPassword) = do + Sem r () +approveDevice zusr tid luid connId (Public.ApproveLegalHoldForUserRequest mPassword) = do assertLegalHoldEnabledForTeam tid - Log.debug $ - Log.field "targets" (toByteString uid) + P.debug $ + Log.field "targets" (toByteString (tUnqualified luid)) . Log.field "action" (Log.val "LegalHold.approveDevice") - liftSem . unless (zusr == uid) $ throw AccessDenied - assertOnTeam uid tid + unless (zusr == tUnqualified luid) $ throw AccessDenied + assertOnTeam (tUnqualified luid) tid ensureReAuthorised zusr mPassword userLHStatus <- - liftSem $ - maybe defUserLegalHoldStatus (view legalHoldStatus) <$> getTeamMember tid uid + maybe defUserLegalHoldStatus (view legalHoldStatus) <$> getTeamMember tid (tUnqualified luid) assertUserLHPending userLHStatus - mPreKeys <- liftSem $ LegalHoldData.selectPendingPrekeys uid + mPreKeys <- LegalHoldData.selectPendingPrekeys (tUnqualified luid) (prekeys, lastPrekey') <- case mPreKeys of Nothing -> do - Log.info $ Log.msg @Text "No prekeys found" - liftSem $ throw NoLegalHoldDeviceAllocated + P.info $ Log.msg @Text "No prekeys found" + throw NoLegalHoldDeviceAllocated Just keys -> pure keys - clientId <- liftSem $ addLegalHoldClientToUser uid connId prekeys lastPrekey' + clientId <- addLegalHoldClientToUser (tUnqualified luid) connId prekeys lastPrekey' -- Note: teamId could be passed in the getLegalHoldAuthToken request instead of lookup up again -- Note: both 'getLegalHoldToken' and 'ensureReAuthorized' check the password -- Note: both 'getLegalHoldToken' and this function in 'assertOnTeam' above -- checks that the user is part of a binding team -- FUTUREWORK: reduce double checks - legalHoldAuthToken <- liftSem $ getLegalHoldAuthToken uid mPassword - LHService.confirmLegalHold clientId tid uid legalHoldAuthToken + legalHoldAuthToken <- getLegalHoldAuthToken (tUnqualified luid) mPassword + LHService.confirmLegalHold clientId tid (tUnqualified luid) legalHoldAuthToken -- TODO: send event at this point (see also: -- https://github.com/wireapp/wire-server/pull/802#pullrequestreview-262280386) - changeLegalholdStatus tid uid userLHStatus UserLegalHoldEnabled + changeLegalholdStatus tid luid userLHStatus UserLegalHoldEnabled where - assertUserLHPending :: Member (Error LegalHoldError) r => UserLegalHoldStatus -> Galley r () - assertUserLHPending userLHStatus = liftSem $ do + assertUserLHPending :: Member (Error LegalHoldError) r => UserLegalHoldStatus -> Sem r () + assertUserLHPending userLHStatus = do case userLHStatus of UserLegalHoldEnabled -> throw UserLegalHoldAlreadyEnabled UserLegalHoldPending -> pure () @@ -659,33 +657,33 @@ approveDevice zusr tid uid connId (Public.ApproveLegalHoldForUserRequest mPasswo disableForUserH :: Members - '[ BotAccess, - BrigAccess, - CodeStore, + '[ BrigAccess, ConversationStore, Error ActionError, Error InvalidInput, Error AuthenticationError, Error ConversationError, - Error FederationError, Error LegalHoldError, Error NotATeamMember, - Error TeamError, ExternalAccess, FederatorAccess, - FireAndForget, GundeckAccess, + Input UTCTime, + Input (Local ()), LegalHoldStore, ListItems LegacyPaging ConvId, MemberStore, - TeamStore + TeamStore, + P.TinyLog, + WaiRoutes ] r => UserId ::: TeamId ::: UserId ::: JsonRequest Public.DisableLegalHoldForUserRequest ::: JSON -> - Galley r Response + Sem r Response disableForUserH (zusr ::: tid ::: uid ::: req ::: _) = do + luid <- qualifyLocal uid disable <- fromJsonBody req - disableForUser zusr tid uid disable <&> \case + disableForUser zusr tid luid disable <&> \case DisableLegalHoldSuccess -> empty DisableLegalHoldWasNotEnabled -> noContent @@ -696,168 +694,162 @@ data DisableLegalHoldForUserResponse disableForUser :: forall r. Members - '[ BotAccess, - BrigAccess, - CodeStore, + '[ BrigAccess, ConversationStore, Error ActionError, Error InvalidInput, Error AuthenticationError, Error ConversationError, - Error FederationError, Error LegalHoldError, Error NotATeamMember, - Error TeamError, ExternalAccess, FederatorAccess, - FireAndForget, GundeckAccess, + Input UTCTime, LegalHoldStore, ListItems LegacyPaging ConvId, MemberStore, - TeamStore + TeamStore, + P.TinyLog ] r => UserId -> TeamId -> - UserId -> + Local UserId -> Public.DisableLegalHoldForUserRequest -> - Galley r DisableLegalHoldForUserResponse -disableForUser zusr tid uid (Public.DisableLegalHoldForUserRequest mPassword) = do - Log.debug $ - Log.field "targets" (toByteString uid) + Sem r DisableLegalHoldForUserResponse +disableForUser zusr tid luid (Public.DisableLegalHoldForUserRequest mPassword) = do + P.debug $ + Log.field "targets" (toByteString (tUnqualified luid)) . Log.field "action" (Log.val "LegalHold.disableForUser") - zusrMembership <- liftSem $ getTeamMember tid zusr + zusrMembership <- getTeamMember tid zusr void $ permissionCheck ChangeLegalHoldUserSettings zusrMembership userLHStatus <- - liftSem $ - maybe defUserLegalHoldStatus (view legalHoldStatus) <$> getTeamMember tid uid + maybe defUserLegalHoldStatus (view legalHoldStatus) <$> getTeamMember tid (tUnqualified luid) if not $ userLHEnabled userLHStatus then pure DisableLegalHoldWasNotEnabled else disableLH userLHStatus $> DisableLegalHoldSuccess where - disableLH :: UserLegalHoldStatus -> Galley r () + disableLH :: UserLegalHoldStatus -> Sem r () disableLH userLHStatus = do ensureReAuthorised zusr mPassword - liftSem $ removeLegalHoldClientFromUser uid - LHService.removeLegalHold tid uid + removeLegalHoldClientFromUser (tUnqualified luid) + LHService.removeLegalHold tid (tUnqualified luid) -- TODO: send event at this point (see also: related TODO in this module in -- 'approveDevice' and -- https://github.com/wireapp/wire-server/pull/802#pullrequestreview-262280386) - changeLegalholdStatus tid uid userLHStatus UserLegalHoldDisabled + changeLegalholdStatus tid luid userLHStatus UserLegalHoldDisabled -- | Allow no-consent => consent without further changes. If LH device is requested, enabled, -- or disabled, make sure the affected connections are screened for policy conflict (anybody -- with no-consent), and put those connections in the appropriate blocked state. changeLegalholdStatus :: Members - '[ BotAccess, - BrigAccess, - CodeStore, + '[ BrigAccess, ConversationStore, Error ActionError, Error InvalidInput, Error ConversationError, - Error FederationError, Error LegalHoldError, - Error NotATeamMember, - Error TeamError, ExternalAccess, FederatorAccess, - FireAndForget, GundeckAccess, + Input UTCTime, LegalHoldStore, ListItems LegacyPaging ConvId, MemberStore, - TeamStore + TeamStore, + P.TinyLog ] r => TeamId -> - UserId -> + Local UserId -> UserLegalHoldStatus -> UserLegalHoldStatus -> - Galley r () -changeLegalholdStatus tid uid old new = do + Sem r () +changeLegalholdStatus tid luid old new = do case old of UserLegalHoldEnabled -> case new of UserLegalHoldEnabled -> noop UserLegalHoldPending -> illegal - UserLegalHoldDisabled -> liftSem update >> removeblocks + UserLegalHoldDisabled -> update >> removeblocks UserLegalHoldNoConsent -> illegal -- UserLegalHoldPending -> case new of - UserLegalHoldEnabled -> liftSem update + UserLegalHoldEnabled -> update UserLegalHoldPending -> noop - UserLegalHoldDisabled -> liftSem update >> removeblocks + UserLegalHoldDisabled -> update >> removeblocks UserLegalHoldNoConsent -> illegal -- UserLegalHoldDisabled -> case new of UserLegalHoldEnabled -> illegal - UserLegalHoldPending -> addblocks >> liftSem update + UserLegalHoldPending -> addblocks >> update UserLegalHoldDisabled -> {- in case the last attempt crashed -} removeblocks UserLegalHoldNoConsent -> {- withdrawing consent is not (yet?) implemented -} illegal -- UserLegalHoldNoConsent -> case new of UserLegalHoldEnabled -> illegal UserLegalHoldPending -> illegal - UserLegalHoldDisabled -> liftSem update + UserLegalHoldDisabled -> update UserLegalHoldNoConsent -> noop where - update = LegalHoldData.setUserLegalHoldStatus tid uid new - removeblocks = void . liftSem $ putConnectionInternal (RemoveLHBlocksInvolving uid) + update = LegalHoldData.setUserLegalHoldStatus tid (tUnqualified luid) new + removeblocks = void $ putConnectionInternal (RemoveLHBlocksInvolving (tUnqualified luid)) addblocks = do - blockNonConsentingConnections uid - handleGroupConvPolicyConflicts uid new + blockNonConsentingConnections (tUnqualified luid) + handleGroupConvPolicyConflicts luid new noop = pure () - illegal = liftSem $ throw UserLegalHoldIllegalOperation + illegal = throw UserLegalHoldIllegalOperation -- FUTUREWORK: make this async? blockNonConsentingConnections :: forall r. - Members '[BrigAccess, Error LegalHoldError, Error NotATeamMember, LegalHoldStore, TeamStore] r => + Members + '[ BrigAccess, + Error LegalHoldError, + TeamStore, + P.TinyLog + ] + r => UserId -> - Galley r () + Sem r () blockNonConsentingConnections uid = do - conns <- liftSem $ getConnectionsUnqualified [uid] Nothing Nothing + conns <- getConnectionsUnqualified [uid] Nothing Nothing errmsgs <- do conflicts <- mconcat <$> findConflicts conns blockConflicts uid conflicts case mconcat errmsgs of [] -> pure () msgs@(_ : _) -> do - Log.warn $ Log.msg @String msgs - liftSem $ throw LegalHoldCouldNotBlockConnections + P.warn $ Log.msg @String msgs + throw LegalHoldCouldNotBlockConnections where - findConflicts :: [ConnectionStatus] -> Galley r [[UserId]] + findConflicts :: [ConnectionStatus] -> Sem r [[UserId]] findConflicts conns = do let (FutureWork @'Public.LegalholdPlusFederationNotImplemented -> _remoteUids, localUids) = (undefined, csTo <$> conns) -- FUTUREWORK: Handle remoteUsers here when federation is implemented for (chunksOf 32 localUids) $ \others -> do - teamsOfUsers <- liftSem $ getUsersTeams others + teamsOfUsers <- getUsersTeams others filterM (fmap (== ConsentNotGiven) . checkConsent teamsOfUsers) others - blockConflicts :: UserId -> [UserId] -> Galley r [String] + blockConflicts :: UserId -> [UserId] -> Sem r [String] blockConflicts _ [] = pure [] blockConflicts userLegalhold othersToBlock@(_ : _) = do - status <- liftSem $ putConnectionInternal (BlockForMissingLHConsent userLegalhold othersToBlock) + status <- putConnectionInternal (BlockForMissingLHConsent userLegalhold othersToBlock) pure $ ["blocking users failed: " <> show (status, othersToBlock) | status /= status200] -setTeamLegalholdWhitelisted :: Member LegalHoldStore r => TeamId -> Galley r () -setTeamLegalholdWhitelisted tid = - liftSem $ - LegalHoldData.setTeamLegalholdWhitelisted tid +setTeamLegalholdWhitelisted :: Member LegalHoldStore r => TeamId -> Sem r () +setTeamLegalholdWhitelisted tid = LegalHoldData.setTeamLegalholdWhitelisted tid -setTeamLegalholdWhitelistedH :: Member LegalHoldStore r => TeamId -> Galley r Response +setTeamLegalholdWhitelistedH :: Member LegalHoldStore r => TeamId -> Sem r Response setTeamLegalholdWhitelistedH tid = do empty <$ setTeamLegalholdWhitelisted tid -unsetTeamLegalholdWhitelisted :: Member LegalHoldStore r => TeamId -> Galley r () -unsetTeamLegalholdWhitelisted tid = - liftSem $ - LegalHoldData.unsetTeamLegalholdWhitelisted tid +unsetTeamLegalholdWhitelisted :: Member LegalHoldStore r => TeamId -> Sem r () +unsetTeamLegalholdWhitelisted tid = LegalHoldData.unsetTeamLegalholdWhitelisted tid -unsetTeamLegalholdWhitelistedH :: Member LegalHoldStore r => TeamId -> Galley r Response +unsetTeamLegalholdWhitelistedH :: Member LegalHoldStore r => TeamId -> Sem r Response unsetTeamLegalholdWhitelistedH tid = do () <- error @@ -866,8 +858,8 @@ unsetTeamLegalholdWhitelistedH tid = do \before you enable the end-point." setStatus status204 empty <$ unsetTeamLegalholdWhitelisted tid -getTeamLegalholdWhitelistedH :: Member LegalHoldStore r => TeamId -> Galley r Response -getTeamLegalholdWhitelistedH tid = liftSem $ do +getTeamLegalholdWhitelistedH :: Member LegalHoldStore r => TeamId -> Sem r Response +getTeamLegalholdWhitelistedH tid = do lhEnabled <- LegalHoldData.isTeamLegalholdWhitelisted tid pure $ if lhEnabled @@ -890,31 +882,25 @@ getTeamLegalholdWhitelistedH tid = liftSem $ do -- one from the database. handleGroupConvPolicyConflicts :: Members - '[ BotAccess, - BrigAccess, - CodeStore, - ConversationStore, + '[ ConversationStore, Error ActionError, Error InvalidInput, Error ConversationError, - Error FederationError, - Error TeamError, ExternalAccess, FederatorAccess, - FireAndForget, GundeckAccess, - LegalHoldStore, + Input UTCTime, ListItems LegacyPaging ConvId, MemberStore, TeamStore ] r => - UserId -> + Local UserId -> UserLegalHoldStatus -> - Galley r () -handleGroupConvPolicyConflicts uid hypotheticalLHStatus = + Sem r () +handleGroupConvPolicyConflicts luid hypotheticalLHStatus = do void $ - iterateConversations uid (toRange (Proxy @500)) $ \convs -> do + iterateConversations luid (toRange (Proxy @500)) $ \convs -> do for_ (filter ((== RegularConv) . Data.convType) convs) $ \conv -> do let FutureWork _convRemoteMembers' = FutureWork @'LegalholdPlusFederationNotImplemented Data.convRemoteMembers @@ -925,22 +911,22 @@ handleGroupConvPolicyConflicts uid hypotheticalLHStatus = zipWith ( \mem (mid, status) -> assert (lmId mem == mid) $ - if lmId mem == uid + if lmId mem == tUnqualified luid then (mem, hypotheticalLHStatus) else (mem, status) ) mems uidsLHStatus - lcnv <- qualifyLocal (Data.convId conv) + let lcnv = qualifyAs luid (Data.convId conv) if any ((== ConsentGiven) . consentGiven . snd) (filter ((== roleNameWireAdmin) . lmConvRoleName . fst) membersAndLHStatus) then do for_ (filter ((== ConsentNotGiven) . consentGiven . snd) membersAndLHStatus) $ \(memberNoConsent, _) -> do - lusr <- qualifyLocal (lmId memberNoConsent) + let lusr = qualifyAs luid (lmId memberNoConsent) removeMemberFromLocalConv lcnv lusr Nothing (qUntagged lusr) else do for_ (filter (userLHEnabled . snd) membersAndLHStatus) $ \(legalholder, _) -> do - lusr <- qualifyLocal (lmId legalholder) + let lusr = qualifyAs luid (lmId legalholder) removeMemberFromLocalConv lcnv lusr Nothing (qUntagged lusr) diff --git a/services/galley/src/Galley/API/LegalHold/Conflicts.hs b/services/galley/src/Galley/API/LegalHold/Conflicts.hs index 11995a36faf..e70937ccd72 100644 --- a/services/galley/src/Galley/API/LegalHold/Conflicts.hs +++ b/services/galley/src/Galley/API/LegalHold/Conflicts.hs @@ -19,22 +19,24 @@ module Galley.API.LegalHold.Conflicts where import Brig.Types.Intra (accountUser) import Control.Lens (view) -import Control.Monad.Error.Class (throwError) -import Control.Monad.Trans.Except (runExceptT) import Data.ByteString.Conversion (toByteString') import Data.Id import Data.LegalHold (UserLegalHoldStatus (..), defUserLegalHoldStatus) import qualified Data.Map as Map import Data.Misc +import Data.Qualified import qualified Data.Set as Set import Galley.API.Util -import Galley.App import Galley.Effects import Galley.Effects.BrigAccess import Galley.Effects.TeamStore import Galley.Options import Galley.Types.Teams hiding (self) import Imports +import Polysemy +import Polysemy.Error +import Polysemy.Input +import qualified Polysemy.TinyLog as P import qualified System.Logger.Class as Log import Wire.API.Team.LegalHold import Wire.API.User @@ -43,12 +45,20 @@ import Wire.API.User.Client as Client data LegalholdConflicts = LegalholdConflicts guardQualifiedLegalholdPolicyConflicts :: - Members '[BrigAccess, TeamStore] r => + Members + '[ BrigAccess, + Error LegalholdConflicts, + Input (Local ()), + Input Opts, + TeamStore, + P.TinyLog + ] + r => LegalholdProtectee -> QualifiedUserClients -> - Galley r (Either LegalholdConflicts ()) + Sem r () guardQualifiedLegalholdPolicyConflicts protectee qclients = do - localDomain <- viewFederationDomain + localDomain <- tDomain <$> qualifyLocal () guardLegalholdPolicyConflicts protectee . UserClients . Map.findWithDefault mempty localDomain @@ -62,26 +72,40 @@ guardQualifiedLegalholdPolicyConflicts protectee qclients = do -- This is a fallback safeguard that shouldn't get triggered if backend and clients work as -- intended. guardLegalholdPolicyConflicts :: - Members '[BrigAccess, TeamStore] r => + Members + '[ BrigAccess, + Error LegalholdConflicts, + Input Opts, + TeamStore, + P.TinyLog + ] + r => LegalholdProtectee -> UserClients -> - Galley r (Either LegalholdConflicts ()) -guardLegalholdPolicyConflicts LegalholdPlusFederationNotImplemented _otherClients = pure . pure $ () -guardLegalholdPolicyConflicts UnprotectedBot _otherClients = pure . pure $ () + Sem r () +guardLegalholdPolicyConflicts LegalholdPlusFederationNotImplemented _otherClients = pure () +guardLegalholdPolicyConflicts UnprotectedBot _otherClients = pure () guardLegalholdPolicyConflicts (ProtectedUser self) otherClients = do - view (options . optSettings . setFeatureFlags . flagLegalHold) >>= \case + opts <- input + case view (optSettings . setFeatureFlags . flagLegalHold) opts of FeatureLegalHoldDisabledPermanently -> case FutureWork @'LegalholdPlusFederationNotImplemented () of - FutureWork () -> pure . pure $ () -- FUTUREWORK: if federation is enabled, we still need to run the guard! + FutureWork () -> pure () -- FUTUREWORK: if federation is enabled, we still need to run the guard! FeatureLegalHoldDisabledByDefault -> guardLegalholdPolicyConflictsUid self otherClients FeatureLegalHoldWhitelistTeamsAndImplicitConsent -> guardLegalholdPolicyConflictsUid self otherClients guardLegalholdPolicyConflictsUid :: forall r. - Members '[BrigAccess, TeamStore] r => + Members + '[ BrigAccess, + Error LegalholdConflicts, + TeamStore, + P.TinyLog + ] + r => UserId -> UserClients -> - Galley r (Either LegalholdConflicts ()) -guardLegalholdPolicyConflictsUid self otherClients = runExceptT $ do + Sem r () +guardLegalholdPolicyConflictsUid self otherClients = do let otherCids :: [ClientId] otherCids = Set.toList . Set.unions . Map.elems . userClients $ otherClients @@ -89,7 +113,7 @@ guardLegalholdPolicyConflictsUid self otherClients = runExceptT $ do otherUids = nub $ Map.keys . userClients $ otherClients when (nub otherUids /= [self {- if all other clients belong to us, there can be no conflict -}]) $ do - allClients :: UserClientsFull <- lift . liftSem $ lookupClientsFull (nub $ self : otherUids) + allClients :: UserClientsFull <- lookupClientsFull (nub $ self : otherUids) let selfClients :: [Client.Client] = allClients @@ -124,8 +148,8 @@ guardLegalholdPolicyConflictsUid self otherClients = runExceptT $ do . Client.fromClientCapabilityList . Client.clientCapabilities - checkConsentMissing :: Galley r Bool - checkConsentMissing = liftSem $ do + checkConsentMissing :: Sem r Bool + checkConsentMissing = do -- (we could also get the profile from brig. would make the code slightly more -- concise, but not really help with the rpc back-and-forth, so, like, why?) mbUser <- accountUser <$$> getUser self @@ -133,25 +157,24 @@ guardLegalholdPolicyConflictsUid self otherClients = runExceptT $ do let lhStatus = maybe defUserLegalHoldStatus (view legalHoldStatus) mbTeamMember pure (lhStatus == UserLegalHoldNoConsent) - lift $ - Log.debug $ - Log.field "self" (toByteString' self) - Log.~~ Log.field "otherClients" (toByteString' $ show otherClients) - Log.~~ Log.field "otherClientHasLH" (toByteString' otherClientHasLH) - Log.~~ Log.field "checkSelfHasOldClients" (toByteString' checkSelfHasOldClients) - Log.~~ Log.field "checkSelfHasLHClients" (toByteString' checkSelfHasLHClients) - Log.~~ Log.msg ("guardLegalholdPolicyConflicts[1]" :: Text) + P.debug $ + Log.field "self" (toByteString' self) + Log.~~ Log.field "otherClients" (toByteString' $ show otherClients) + Log.~~ Log.field "otherClientHasLH" (toByteString' otherClientHasLH) + Log.~~ Log.field "checkSelfHasOldClients" (toByteString' checkSelfHasOldClients) + Log.~~ Log.field "checkSelfHasLHClients" (toByteString' checkSelfHasLHClients) + Log.~~ Log.msg ("guardLegalholdPolicyConflicts[1]" :: Text) -- (I've tried to order the following checks for minimum IO; did it work? ~~fisx) when otherClientHasLH $ do when checkSelfHasOldClients $ do - lift $ Log.debug $ Log.msg ("guardLegalholdPolicyConflicts[2]: old clients" :: Text) - throwError LegalholdConflicts + P.debug $ Log.msg ("guardLegalholdPolicyConflicts[2]: old clients" :: Text) + throw LegalholdConflicts unless checkSelfHasLHClients {- carrying a LH device implies having granted LH consent -} $ do - whenM (lift checkConsentMissing) $ do + whenM checkConsentMissing $ do -- We assume this is impossible, since conversations are automatically -- blocked if LH consent is missing of any participant. -- We add this check here as an extra failsafe. - lift $ Log.debug $ Log.msg ("guardLegalholdPolicyConflicts[3]: consent missing" :: Text) - throwError LegalholdConflicts + P.debug $ Log.msg ("guardLegalholdPolicyConflicts[3]: consent missing" :: Text) + throw LegalholdConflicts diff --git a/services/galley/src/Galley/API/Mapping.hs b/services/galley/src/Galley/API/Mapping.hs index 3d193b2f6c8..e972a092041 100644 --- a/services/galley/src/Galley/API/Mapping.hs +++ b/services/galley/src/Galley/API/Mapping.hs @@ -30,15 +30,13 @@ import Data.Domain (Domain) import Data.Id (UserId, idToText) import Data.Qualified import Galley.API.Error -import Galley.API.Util (qualifyLocal) -import Galley.App import qualified Galley.Data.Conversation as Data import Galley.Data.Types (convId) import Galley.Types.Conversations.Members import Imports import Polysemy import Polysemy.Error -import qualified System.Logger.Class as Log +import qualified Polysemy.TinyLog as P import System.Logger.Message (msg, val, (+++)) import Wire.API.Conversation hiding (Member (..)) import qualified Wire.API.Conversation as Conversation @@ -48,22 +46,21 @@ import Wire.API.Federation.API.Galley -- -- Throws "bad-state" when the user is not part of the conversation. conversationView :: - Member (Error InternalError) r => - UserId -> + Members '[Error InternalError, P.TinyLog] r => + Local UserId -> Data.Conversation -> - Galley r Conversation -conversationView uid conv = do - luid <- qualifyLocal uid + Sem r Conversation +conversationView luid conv = do let mbConv = conversationViewMaybe luid conv maybe memberNotFound pure mbConv where memberNotFound = do - Log.err . msg $ + P.err . msg $ val "User " - +++ idToText uid + +++ idToText (tUnqualified luid) +++ val " is not a member of conv " +++ idToText (convId conv) - liftSem $ throw BadMemberState + throw BadMemberState -- | View for a given user of a stored conversation. -- @@ -83,16 +80,12 @@ conversationViewMaybe luid conv = do (ConvMembers self others) -- | View for a local user of a remote conversation. --- --- If the local user is not actually present in the conversation, simply --- discard the conversation altogether. This should only happen if the remote --- backend is misbehaving. remoteConversationView :: Local UserId -> MemberStatus -> Remote RemoteConversation -> - Maybe Conversation -remoteConversationView uid status (qUntagged -> Qualified rconv rDomain) = do + Conversation +remoteConversationView uid status (qUntagged -> Qualified rconv rDomain) = let mems = rcnvMembers rconv others = rcmOthers mems self = @@ -104,7 +97,7 @@ remoteConversationView uid status (qUntagged -> Qualified rconv rDomain) = do lmStatus = status, lmConvRoleName = rcmSelfRole mems } - pure $ Conversation (Qualified (rcnvId rconv) rDomain) (rcnvMetadata rconv) (ConvMembers self others) + in Conversation (Qualified (rcnvId rconv) rDomain) (rcnvMetadata rconv) (ConvMembers self others) -- | Convert a local conversation to a structure to be returned to a remote -- backend. diff --git a/services/galley/src/Galley/API/Message.hs b/services/galley/src/Galley/API/Message.hs index 4bd82de30d7..4d32905836d 100644 --- a/services/galley/src/Galley/API/Message.hs +++ b/services/galley/src/Galley/API/Message.hs @@ -20,10 +20,9 @@ import Data.Map.Lens (toMapOf) import Data.Qualified import qualified Data.Set as Set import Data.Set.Lens -import Data.Time.Clock (UTCTime, getCurrentTime) -import Galley.API.LegalHold.Conflicts (guardQualifiedLegalholdPolicyConflicts) +import Data.Time.Clock (UTCTime) +import Galley.API.LegalHold.Conflicts import Galley.API.Util -import Galley.App import Galley.Data.Services as Data import Galley.Effects import Galley.Effects.BrigAccess @@ -34,11 +33,15 @@ import Galley.Effects.FederatorAccess import Galley.Effects.GundeckAccess hiding (Push) import Galley.Effects.MemberStore import Galley.Intra.Push -import Galley.Options (optSettings, setIntraListing) +import Galley.Options import qualified Galley.Types.Clients as Clients import Galley.Types.Conversations.Members import Gundeck.Types.Push.V2 (RecipientClients (..)) import Imports hiding (forkIO) +import Polysemy +import Polysemy.Error +import Polysemy.Input +import qualified Polysemy.TinyLog as P import qualified System.Logger.Class as Log import Wire.API.Event.Conversation import qualified Wire.API.Federation.API.Brig as FederatedBrig @@ -181,23 +184,22 @@ checkMessageClients sender participantMap recipientMap mismatchStrat = getRemoteClients :: Member FederatorAccess r => [RemoteMember] -> - Galley r (Map (Domain, UserId) (Set ClientId)) + Sem r (Map (Domain, UserId) (Set ClientId)) getRemoteClients remoteMembers = -- concatenating maps is correct here, because their sets of keys are disjoint - liftSem $ - mconcat . map tUnqualified - <$> runFederatedConcurrently (map rmId remoteMembers) getRemoteClientsFromDomain + mconcat . map tUnqualified + <$> runFederatedConcurrently (map rmId remoteMembers) getRemoteClientsFromDomain where getRemoteClientsFromDomain (qUntagged -> Qualified uids domain) = Map.mapKeys (domain,) . fmap (Set.map pubClientId) . userMap <$> FederatedBrig.getUserClients FederatedBrig.clientRoutes (FederatedBrig.GetUserClients uids) postRemoteOtrMessage :: - Members '[ConversationStore, FederatorAccess] r => + Members '[FederatorAccess] r => Qualified UserId -> Remote ConvId -> LByteString -> - Galley r (PostOtrResponse MessageSendingStatus) + Sem r (PostOtrResponse MessageSendingStatus) postRemoteOtrMessage sender conv rawMsg = do let msr = FederatedGalley.MessageSendRequest @@ -206,42 +208,45 @@ postRemoteOtrMessage sender conv rawMsg = do FederatedGalley.msrRawMessage = Base64ByteString rawMsg } rpc = FederatedGalley.sendMessage FederatedGalley.clientRoutes (qDomain sender) msr - liftSem $ FederatedGalley.msResponse <$> runFederated conv rpc + FederatedGalley.msResponse <$> runFederated conv rpc postQualifiedOtrMessage :: Members - '[ BotAccess, - BrigAccess, + '[ BrigAccess, ClientStore, ConversationStore, FederatorAccess, GundeckAccess, ExternalAccess, + Input (Local ()), -- FUTUREWORK: remove this + Input Opts, + Input UTCTime, MemberStore, - TeamStore + TeamStore, + P.TinyLog ] r => UserType -> Qualified UserId -> Maybe ConnId -> - ConvId -> + Local ConvId -> QualifiedNewOtrMessage -> - Galley r (PostOtrResponse MessageSendingStatus) -postQualifiedOtrMessage senderType sender mconn convId msg = runExceptT $ do - alive <- lift . liftSem $ isConversationAlive convId - localDomain <- viewFederationDomain - now <- liftIO getCurrentTime + Sem r (PostOtrResponse MessageSendingStatus) +postQualifiedOtrMessage senderType sender mconn lcnv msg = runExceptT $ do + alive <- lift $ isConversationAlive (tUnqualified lcnv) + let localDomain = tDomain lcnv + now <- lift $ input let nowMillis = toUTCTimeMillis now let senderDomain = qDomain sender senderUser = qUnqualified sender let senderClient = qualifiedNewOtrSender msg unless alive $ do - lift . liftSem $ deleteConversation convId + lift $ deleteConversation (tUnqualified lcnv) throwError MessageNotSentConversationNotFound -- conversation members - localMembers <- lift . liftSem $ getLocalMembers convId - remoteMembers <- lift . liftSem $ getRemoteMembers convId + localMembers <- lift $ getLocalMembers (tUnqualified lcnv) + remoteMembers <- lift $ getRemoteMembers (tUnqualified lcnv) let localMemberIds = lmId <$> localMembers localMemberMap :: Map UserId LocalMember @@ -250,7 +255,7 @@ postQualifiedOtrMessage senderType sender mconn convId msg = runExceptT $ do members = Set.map (`Qualified` localDomain) (Map.keysSet localMemberMap) <> Set.fromList (map (qUntagged . rmId) remoteMembers) - isInternal <- view $ options . optSettings . setIntraListing + isInternal <- lift $ view (optSettings . setIntraListing) <$> input -- check if the sender is part of the conversation unless (Set.member sender members) $ @@ -258,7 +263,7 @@ postQualifiedOtrMessage senderType sender mconn convId msg = runExceptT $ do -- get local clients localClients <- - lift . liftSem $ + lift $ if isInternal then Clients.fromUserClients <$> lookupClients localMemberIds else getClients localMemberIds @@ -292,10 +297,13 @@ postQualifiedOtrMessage senderType sender mconn convId msg = runExceptT $ do missingClients = qmMissing mismatch legalholdErr = pure MessageNotSentLegalhold clientMissingErr = pure $ MessageNotSentClientMissing otrResult - guardQualifiedLegalholdPolicyConflicts lhProtectee missingClients - & eitherM (const legalholdErr) (const clientMissingErr) - & lift - >>= throwError + e <- + lift + . runLocalInput lcnv + . eitherM (const legalholdErr) (const clientMissingErr) + . runError @LegalholdConflicts + $ guardQualifiedLegalholdPolicyConflicts lhProtectee missingClients + throwError e failedToSend <- lift $ @@ -304,7 +312,7 @@ postQualifiedOtrMessage senderType sender mconn convId msg = runExceptT $ do sender senderClient mconn - convId + lcnv localMemberMap (qualifiedNewOtrMetadata msg) validMessages @@ -316,24 +324,25 @@ postQualifiedOtrMessage senderType sender mconn convId msg = runExceptT $ do -- | Send both local and remote messages, return the set of clients for which -- sending has failed. sendMessages :: - Members '[BotAccess, GundeckAccess, ExternalAccess, FederatorAccess] r => + Members '[GundeckAccess, ExternalAccess, FederatorAccess, Input (Local ()), P.TinyLog] r => + -- FUTUREWORK: remove Input (Local ()) effect UTCTime -> Qualified UserId -> ClientId -> Maybe ConnId -> - ConvId -> + Local ConvId -> Map UserId LocalMember -> MessageMetadata -> Map (Domain, UserId, ClientId) ByteString -> - Galley r QualifiedUserClients -sendMessages now sender senderClient mconn conv localMemberMap metadata messages = do - localDomain <- viewFederationDomain + Sem r QualifiedUserClients +sendMessages now sender senderClient mconn lcnv localMemberMap metadata messages = do let messageMap = byDomain $ fmap toBase64Text messages - let send dom - | localDomain == dom = - sendLocalMessages now sender senderClient mconn (Qualified conv localDomain) localMemberMap metadata - | otherwise = - sendRemoteMessages (toRemoteUnsafe dom ()) now sender senderClient conv metadata + let send dom = + foldQualified + lcnv + (\_ -> sendLocalMessages now sender senderClient mconn (qUntagged lcnv) localMemberMap metadata) + (\r -> sendRemoteMessages r now sender senderClient lcnv metadata) + (Qualified () dom) mkQualifiedUserClientsByDomain <$> Map.traverseWithKey send messageMap where @@ -344,7 +353,7 @@ sendMessages now sender senderClient mconn conv localMemberMap metadata messages mempty sendLocalMessages :: - Members '[BotAccess, GundeckAccess, ExternalAccess] r => + Members '[GundeckAccess, ExternalAccess, Input (Local ()), P.TinyLog] r => UTCTime -> Qualified UserId -> ClientId -> @@ -353,35 +362,35 @@ sendLocalMessages :: Map UserId LocalMember -> MessageMetadata -> Map (UserId, ClientId) Text -> - Galley r (Set (UserId, ClientId)) -sendLocalMessages now sender senderClient mconn conv localMemberMap metadata localMessages = do - localDomain <- viewFederationDomain + Sem r (Set (UserId, ClientId)) +sendLocalMessages now sender senderClient mconn qcnv localMemberMap metadata localMessages = do + loc <- qualifyLocal () let events = localMessages & reindexed snd itraversed %@~ newMessageEvent - conv + qcnv sender senderClient (mmData metadata) now pushes = events & itraversed - %@~ newMessagePush localDomain localMemberMap mconn metadata - runMessagePush conv (pushes ^. traversed) + %@~ newMessagePush loc localMemberMap mconn metadata + runMessagePush qcnv (pushes ^. traversed) pure mempty sendRemoteMessages :: forall r x. - Member FederatorAccess r => + Members '[FederatorAccess, P.TinyLog] r => Remote x -> UTCTime -> Qualified UserId -> ClientId -> - ConvId -> + Local ConvId -> MessageMetadata -> Map (UserId, ClientId) Text -> - Galley r (Set (UserId, ClientId)) -sendRemoteMessages domain now sender senderClient conv metadata messages = (handle =<<) $ do + Sem r (Set (UserId, ClientId)) +sendRemoteMessages domain now sender senderClient lcnv metadata messages = (handle =<<) $ do let rcpts = foldr (\((u, c), t) -> Map.insertWith (<>) u (Map.singleton c t)) @@ -393,23 +402,20 @@ sendRemoteMessages domain now sender senderClient conv metadata messages = (hand FederatedGalley.rmData = mmData metadata, FederatedGalley.rmSender = sender, FederatedGalley.rmSenderClient = senderClient, - FederatedGalley.rmConversation = conv, + FederatedGalley.rmConversation = tUnqualified lcnv, FederatedGalley.rmPriority = mmNativePriority metadata, FederatedGalley.rmPush = mmNativePush metadata, FederatedGalley.rmTransient = mmTransient metadata, FederatedGalley.rmRecipients = UserClientMap rcpts } - -- Semantically, the origin domain should be the converation domain. Here one - -- backend has only one domain so we just pick it from the environment. - originDomain <- viewFederationDomain - let rpc = FederatedGalley.onMessageSent FederatedGalley.clientRoutes originDomain rm - liftSem $ runFederatedEither domain rpc + let rpc = FederatedGalley.onMessageSent FederatedGalley.clientRoutes (tDomain lcnv) rm + runFederatedEither domain rpc where - handle :: Either FederationError a -> Galley r (Set (UserId, ClientId)) + handle :: Either FederationError a -> Sem r (Set (UserId, ClientId)) handle (Right _) = pure mempty handle (Left e) = do - Log.warn $ - Log.field "conversation" (toByteString' conv) + P.warn $ + Log.field "conversation" (toByteString' (tUnqualified lcnv)) Log.~~ Log.field "domain" (toByteString' (tDomain domain)) Log.~~ Log.field "exception" (encode (federationErrorToWai e)) Log.~~ Log.msg ("Remote message sending failed" :: Text) @@ -445,21 +451,21 @@ newBotPush b e = MessagePush {userPushes = mempty, botPushes = pure (b, e)} runMessagePush :: forall r. - Members '[BotAccess, GundeckAccess, ExternalAccess] r => + Members '[GundeckAccess, ExternalAccess, Input (Local ()), P.TinyLog] r => Qualified ConvId -> MessagePush -> - Galley r () -runMessagePush cnv mp = do - liftSem $ push (userPushes mp) + Sem r () +runMessagePush qcnv mp = do + push (userPushes mp) pushToBots (botPushes mp) where - pushToBots :: [(BotMember, Event)] -> Galley r () + pushToBots :: [(BotMember, Event)] -> Sem r () pushToBots pushes = do - localDomain <- viewFederationDomain - if localDomain /= qDomain cnv + localDomain <- tDomain <$> qualifyLocal () + if localDomain /= qDomain qcnv then unless (null pushes) $ do - Log.warn $ Log.msg ("Ignoring messages for local bots in a remote conversation" :: ByteString) . Log.field "conversation" (show cnv) - else liftSem $ deliverAndDeleteAsync (qUnqualified cnv) pushes + P.warn $ Log.msg ("Ignoring messages for local bots in a remote conversation" :: ByteString) . Log.field "conversation" (show qcnv) + else deliverAndDeleteAsync (qUnqualified qcnv) pushes newMessageEvent :: Qualified ConvId -> Qualified UserId -> ClientId -> Maybe Text -> UTCTime -> ClientId -> Text -> Event newMessageEvent convId sender senderClient dat time receiverClient cipherText = @@ -473,14 +479,14 @@ newMessageEvent convId sender senderClient dat time receiverClient cipherText = newMessagePush :: Ord k => - Domain -> + Local x -> Map k LocalMember -> Maybe ConnId -> MessageMetadata -> (k, ClientId) -> Event -> MessagePush -newMessagePush localDomain members mconn mm (k, client) e = fromMaybe mempty $ do +newMessagePush loc members mconn mm (k, client) e = fromMaybe mempty $ do member <- Map.lookup k members newBotMessagePush member <|> newUserMessagePush member where @@ -489,7 +495,7 @@ newMessagePush localDomain members mconn mm (k, client) e = fromMaybe mempty $ d newUserMessagePush :: LocalMember -> Maybe MessagePush newUserMessagePush member = fmap newUserPush $ - newConversationEventPush localDomain e [lmId member] + newConversationEventPush e (qualifyAs loc [lmId member]) <&> set pushConn mconn . set pushNativePriority (mmNativePriority mm) . set pushRoute (bool RouteDirect RouteAny (mmNativePush mm)) diff --git a/services/galley/src/Galley/API/One2One.hs b/services/galley/src/Galley/API/One2One.hs index 1458e9c464c..348da8c1d05 100644 --- a/services/galley/src/Galley/API/One2One.hs +++ b/services/galley/src/Galley/API/One2One.hs @@ -24,7 +24,6 @@ where import Data.Id import Data.Qualified -import Galley.App (Galley, liftSem) import Galley.Data.Conversation import Galley.Effects.ConversationStore import Galley.Effects.MemberStore @@ -38,8 +37,8 @@ iUpsertOne2OneConversation :: forall r. Members '[ConversationStore, MemberStore] r => UpsertOne2OneConversationRequest -> - Galley r UpsertOne2OneConversationResponse -iUpsertOne2OneConversation UpsertOne2OneConversationRequest {..} = liftSem $ do + Sem r UpsertOne2OneConversationResponse +iUpsertOne2OneConversation UpsertOne2OneConversationRequest {..} = do let convId = fromMaybe (one2OneConvId (qUntagged uooLocalUser) (qUntagged uooRemoteUser)) uooConvId let dolocal :: Local ConvId -> Sem r () diff --git a/services/galley/src/Galley/API/Public.hs b/services/galley/src/Galley/API/Public.hs index e4213142718..3027ba070ab 100644 --- a/services/galley/src/Galley/API/Public.hs +++ b/services/galley/src/Galley/API/Public.hs @@ -41,6 +41,7 @@ import Galley.API.Teams.Features (DoAuth (..), getFeatureStatus, setFeatureStatu import qualified Galley.API.Teams.Features as Features import qualified Galley.API.Update as Update import Galley.App +import Galley.Cassandra.Paging import Imports hiding (head) import Network.HTTP.Types import Network.Wai @@ -51,6 +52,7 @@ import Network.Wai.Routing hiding (route) import Network.Wai.Utilities import Network.Wai.Utilities.Swagger import Network.Wai.Utilities.ZAuth hiding (ZAuthUser) +import Polysemy import Servant hiding (Handler, JSON, addHeader, contentType, respond) import Servant.Server.Generic (genericServerT) import Servant.Swagger.Internal.Orphans () @@ -72,7 +74,7 @@ import qualified Wire.API.Team.SearchVisibility as Public import qualified Wire.API.User as Public (UserIdList, modelUserIdList) import Wire.Swagger (int32Between) -servantSitemap :: ServerT GalleyAPI.ServantAPI (Galley GalleyEffects) +servantSitemap :: ServerT GalleyAPI.ServantAPI (Sem GalleyEffects) servantSitemap = genericServerT $ GalleyAPI.Api @@ -121,7 +123,7 @@ servantSitemap = getFeatureStatus @'Public.TeamFeatureLegalHold Features.getLegalholdStatusInternal . DoAuth, GalleyAPI.teamFeatureStatusLegalHoldPut = - setFeatureStatus @'Public.TeamFeatureLegalHold Features.setLegalholdStatusInternal . DoAuth, + setFeatureStatus @'Public.TeamFeatureLegalHold (Features.setLegalholdStatusInternal @InternalPaging) . DoAuth, GalleyAPI.teamFeatureStatusSearchVisibilityGet = getFeatureStatus @'Public.TeamFeatureSearchVisibility Features.getTeamSearchVisibilityAvailableInternal . DoAuth, @@ -181,7 +183,7 @@ servantSitemap = GalleyAPI.featureConfigSelfDeletingMessagesGet = Features.getFeatureConfig @'Public.TeamFeatureSelfDeletingMessages Features.getSelfDeletingMessagesInternal } -sitemap :: Routes ApiBuilder (Galley GalleyEffects) () +sitemap :: Routes ApiBuilder (Sem GalleyEffects) () sitemap = do -- Team API ----------------------------------------------------------- @@ -738,7 +740,7 @@ sitemap = do errorResponse (Error.errorDescriptionTypeToWai @Error.UnknownClient) errorResponse Error.broadcastLimitExceeded -apiDocs :: Routes ApiBuilder (Galley r) () +apiDocs :: Routes ApiBuilder (Sem r) () apiDocs = get "/conversations/api-docs" (continue docs) $ accept "application" "json" @@ -746,7 +748,7 @@ apiDocs = type JSON = Media "application" "json" -docs :: JSON ::: ByteString -> Galley r Response +docs :: JSON ::: ByteString -> Sem r Response docs (_ ::: url) = do let models = Public.Swagger.models let apidoc = encode $ mkSwaggerApi (decodeLatin1 url) models sitemap diff --git a/services/galley/src/Galley/API/Query.hs b/services/galley/src/Galley/API/Query.hs index e8983fc1ff3..40e3653ec80 100644 --- a/services/galley/src/Galley/API/Query.hs +++ b/services/galley/src/Galley/API/Query.hs @@ -34,8 +34,6 @@ module Galley.API.Query where import qualified Cassandra as C -import Control.Lens (sequenceAOf) -import Control.Monad.Trans.Except import qualified Data.ByteString.Lazy as LBS import Data.Code import Data.CommaSeparatedList @@ -49,11 +47,11 @@ import qualified Data.Set as Set import Galley.API.Error import qualified Galley.API.Mapping as Mapping import Galley.API.Util -import Galley.App import Galley.Cassandra.Paging import qualified Galley.Data.Types as Data import Galley.Effects import qualified Galley.Effects.ConversationStore as E +import qualified Galley.Effects.FederatorAccess as E import qualified Galley.Effects.ListItems as E import qualified Galley.Effects.MemberStore as E import Galley.Types @@ -66,35 +64,37 @@ import Network.Wai.Predicate hiding (Error, result, setStatus) import Network.Wai.Utilities hiding (Error) import Polysemy import Polysemy.Error +import Polysemy.Input +import qualified Polysemy.TinyLog as P import qualified System.Logger.Class as Logger -import UnliftIO (pooledForConcurrentlyN) import Wire.API.Conversation (ConversationCoverView (..)) import qualified Wire.API.Conversation as Public import qualified Wire.API.Conversation.Role as Public import Wire.API.ErrorDescription import Wire.API.Federation.API.Galley (gcresConvs) import qualified Wire.API.Federation.API.Galley as FederatedGalley -import Wire.API.Federation.Client (FederationError (FederationUnexpectedBody), executeFederated) +import Wire.API.Federation.Client (FederationError (..)) import qualified Wire.API.Provider.Bot as Public import qualified Wire.API.Routes.MultiTablePaging as Public getBotConversationH :: - Members '[ConversationStore, Error ConversationError] r => + Members '[ConversationStore, Error ConversationError, Input (Local ())] r => BotId ::: ConvId ::: JSON -> - Galley r Response + Sem r Response getBotConversationH (zbot ::: zcnv ::: _) = do - json <$> getBotConversation zbot zcnv + lcnv <- qualifyLocal zcnv + json <$> getBotConversation zbot lcnv getBotConversation :: Members '[ConversationStore, Error ConversationError] r => BotId -> - ConvId -> - Galley r Public.BotConvView -getBotConversation zbot zcnv = do - (c, _) <- getConversationAndMemberWithError ConvNotFound (botUserId zbot) zcnv - domain <- viewFederationDomain - let cmems = mapMaybe (mkMember domain) (toList (Data.convLocalMembers c)) - pure $ Public.botConvView zcnv (Data.convName c) cmems + Local ConvId -> + Sem r Public.BotConvView +getBotConversation zbot lcnv = do + (c, _) <- getConversationAndMemberWithError ConvNotFound (botUserId zbot) lcnv + let domain = tDomain lcnv + cmems = mapMaybe (mkMember domain) (toList (Data.convLocalMembers c)) + pure $ Public.botConvView (tUnqualified lcnv) (Data.convName c) cmems where mkMember :: Domain -> LocalMember -> Maybe OtherMember mkMember domain m @@ -104,13 +104,13 @@ getBotConversation zbot zcnv = do Just (OtherMember (Qualified (lmId m) domain) (lmService m) (lmConvRoleName m)) getUnqualifiedConversation :: - Members '[ConversationStore, Error ConversationError, Error InternalError] r => - UserId -> + Members '[ConversationStore, Error ConversationError, Error InternalError, P.TinyLog] r => + Local UserId -> ConvId -> - Galley r Public.Conversation -getUnqualifiedConversation zusr cnv = do - c <- getConversationAndCheckMembership zusr cnv - Mapping.conversationView zusr c + Sem r Public.Conversation +getUnqualifiedConversation lusr cnv = do + c <- getConversationAndCheckMembership (tUnqualified lusr) (qualifyAs lusr cnv) + Mapping.conversationView lusr c getConversation :: forall r. @@ -118,38 +118,46 @@ getConversation :: '[ ConversationStore, Error ConversationError, Error FederationError, - Error InternalError + Error InternalError, + FederatorAccess, + P.TinyLog ] r => - UserId -> + Local UserId -> Qualified ConvId -> - Galley r Public.Conversation -getConversation zusr cnv = do - lusr <- qualifyLocal zusr + Sem r Public.Conversation +getConversation lusr cnv = do foldQualified lusr - (getUnqualifiedConversation zusr . tUnqualified) + (getUnqualifiedConversation lusr . tUnqualified) getRemoteConversation cnv where - getRemoteConversation :: Remote ConvId -> Galley r Public.Conversation + getRemoteConversation :: Remote ConvId -> Sem r Public.Conversation getRemoteConversation remoteConvId = do - conversations <- getRemoteConversations zusr [remoteConvId] - liftSem $ case conversations of + conversations <- getRemoteConversations lusr [remoteConvId] + case conversations of [] -> throw ConvNotFound [conv] -> pure conv -- _convs -> throw (federationUnexpectedBody "expected one conversation, got multiple") _convs -> throw $ FederationUnexpectedBody "expected one conversation, got multiple" getRemoteConversations :: - Members '[ConversationStore, Error ConversationError, Error FederationError] r => - UserId -> + Members + '[ ConversationStore, + Error ConversationError, + Error FederationError, + FederatorAccess, + P.TinyLog + ] + r => + Local UserId -> [Remote ConvId] -> - Galley r [Public.Conversation] -getRemoteConversations zusr remoteConvs = - getRemoteConversationsWithFailures zusr remoteConvs >>= \case + Sem r [Public.Conversation] +getRemoteConversations lusr remoteConvs = + getRemoteConversationsWithFailures lusr remoteConvs >>= \case -- throw first error - (failed : _, _) -> liftSem . throwFgcError $ failed + (failed : _, _) -> throwFgcError $ failed ([], result) -> pure result data FailedGetConversationReason @@ -188,17 +196,14 @@ partitionGetConversationFailures = bimap concat concat . partitionEithers . map split (FailedGetConversation convs (FailedGetConversationRemotely _)) = Right convs getRemoteConversationsWithFailures :: - Member ConversationStore r => - UserId -> + Members '[ConversationStore, FederatorAccess, P.TinyLog] r => + Local UserId -> [Remote ConvId] -> - Galley r ([FailedGetConversation], [Public.Conversation]) -getRemoteConversationsWithFailures zusr convs = do - localDomain <- viewFederationDomain - lusr <- qualifyLocal zusr - + Sem r ([FailedGetConversation], [Public.Conversation]) +getRemoteConversationsWithFailures lusr convs = do -- get self member statuses from the database - statusMap <- liftSem $ E.getRemoteConversationStatus zusr convs - let remoteView :: Remote FederatedGalley.RemoteConversation -> Maybe Conversation + statusMap <- E.getRemoteConversationStatus (tUnqualified lusr) convs + let remoteView :: Remote FederatedGalley.RemoteConversation -> Conversation remoteView rconv = Mapping.remoteConversationView lusr @@ -214,49 +219,45 @@ getRemoteConversationsWithFailures zusr convs = do | otherwise = [failedGetConversationLocally (map qUntagged locallyNotFound)] -- request conversations from remote backends - liftGalley0 - . fmap (bimap (localFailures <>) concat . partitionEithers) - . pooledForConcurrentlyN 8 (bucketRemote locallyFound) - $ \someConvs -> do - let req = FederatedGalley.GetConversationsRequest zusr (tUnqualified someConvs) - rpc = FederatedGalley.getConversations FederatedGalley.clientRoutes localDomain req - handleFailures (sequenceAOf tUnqualifiedL someConvs) $ do - rconvs <- gcresConvs <$> executeFederated (tDomain someConvs) rpc - pure $ mapMaybe (remoteView . qualifyAs someConvs) rconvs + let rpc = FederatedGalley.getConversations FederatedGalley.clientRoutes (tDomain lusr) + resp <- + E.runFederatedConcurrentlyEither locallyFound $ \someConvs -> + rpc $ FederatedGalley.GetConversationsRequest (tUnqualified lusr) (tUnqualified someConvs) + bimap (localFailures <>) (map remoteView . concat) + . partitionEithers + <$> traverse handleFailure resp where - handleFailures :: - [Remote ConvId] -> - ExceptT FederationError Galley0 a -> - Galley0 (Either FailedGetConversation a) - handleFailures rconvs action = runExceptT - . withExceptT (failedGetConversationRemotely rconvs) - . catchE action - $ \e -> do - lift . Logger.warn $ - Logger.msg ("Error occurred while fetching remote conversations" :: ByteString) - . Logger.field "error" (show e) - throwE e + handleFailure :: + Members '[P.TinyLog] r => + Either (Remote [ConvId], FederationError) (Remote FederatedGalley.GetConversationsResponse) -> + Sem r (Either FailedGetConversation [Remote FederatedGalley.RemoteConversation]) + handleFailure (Left (rcids, e)) = do + P.warn $ + Logger.msg ("Error occurred while fetching remote conversations" :: ByteString) + . Logger.field "error" (show e) + pure . Left $ failedGetConversationRemotely (sequenceA rcids) e + handleFailure (Right c) = pure . Right . traverse gcresConvs $ c getConversationRoles :: Members '[ConversationStore, Error ConversationError] r => - UserId -> + Local UserId -> ConvId -> - Galley r Public.ConversationRolesList -getConversationRoles zusr cnv = do - void $ getConversationAndCheckMembership zusr cnv + Sem r Public.ConversationRolesList +getConversationRoles lusr cnv = do + void $ getConversationAndCheckMembership (tUnqualified lusr) (qualifyAs lusr cnv) -- NOTE: If/when custom roles are added, these roles should -- be merged with the team roles (if they exist) pure $ Public.ConversationRolesList wireConvRoles conversationIdsPageFromUnqualified :: Member (ListItems LegacyPaging ConvId) r => - UserId -> + Local UserId -> Maybe ConvId -> Maybe (Range 1 1000 Int32) -> - Galley r (Public.ConversationList ConvId) -conversationIdsPageFromUnqualified zusr start msize = liftSem $ do + Sem r (Public.ConversationList ConvId) +conversationIdsPageFromUnqualified lusr start msize = do let size = fromMaybe (toRange (Proxy @1000)) msize - ids <- E.listItems zusr start size + ids <- E.listItems (tUnqualified lusr) start size pure $ Public.ConversationList (resultSetResult ids) @@ -275,12 +276,12 @@ conversationIdsPageFrom :: ( p ~ CassandraPaging, Members '[ListItems p ConvId, ListItems p (Remote ConvId)] r ) => - UserId -> + Local UserId -> Public.GetPaginatedConversationIds -> - Galley r Public.ConvIdsPage -conversationIdsPageFrom zusr Public.GetMultiTablePageRequest {..} = do - localDomain <- viewFederationDomain - liftSem $ case gmtprState of + Sem r Public.ConvIdsPage +conversationIdsPageFrom lusr Public.GetMultiTablePageRequest {..} = do + let localDomain = tDomain lusr + case gmtprState of Just (Public.ConversationPagingState Public.PagingRemotes stateBS) -> remotesOnly (mkState <$> stateBS) gmtprSize _ -> localsAndRemotes localDomain (fmap mkState . Public.mtpsState =<< gmtprState) gmtprSize @@ -296,7 +297,7 @@ conversationIdsPageFrom zusr Public.GetMultiTablePageRequest {..} = do localsAndRemotes localDomain pagingState size = do localPage <- pageToConvIdPage Public.PagingLocals . fmap (`Qualified` localDomain) - <$> E.listItems zusr pagingState size + <$> E.listItems (tUnqualified lusr) pagingState size let remainingSize = fromRange size - fromIntegral (length (Public.mtpResults localPage)) if Public.mtpHasMore localPage || remainingSize <= 0 then pure localPage {Public.mtpHasMore = True} -- We haven't checked the remotes yet, so has_more must always be True here. @@ -312,7 +313,7 @@ conversationIdsPageFrom zusr Public.GetMultiTablePageRequest {..} = do remotesOnly pagingState size = pageToConvIdPage Public.PagingRemotes . fmap (qUntagged @'QRemote) - <$> E.listItems zusr pagingState size + <$> E.listItems (tUnqualified lusr) pagingState size pageToConvIdPage :: Public.LocalOrRemoteTable -> C.PageWithState (Qualified ConvId) -> Public.ConvIdsPage pageToConvIdPage table page@C.PageWithState {..} = @@ -323,30 +324,30 @@ conversationIdsPageFrom zusr Public.GetMultiTablePageRequest {..} = do } getConversations :: - Members '[Error InternalError, ListItems LegacyPaging ConvId, ConversationStore] r => - UserId -> + Members '[Error InternalError, ListItems LegacyPaging ConvId, ConversationStore, P.TinyLog] r => + Local UserId -> Maybe (Range 1 32 (CommaSeparatedList ConvId)) -> Maybe ConvId -> Maybe (Range 1 500 Int32) -> - Galley r (Public.ConversationList Public.Conversation) -getConversations user mids mstart msize = do - ConversationList cs more <- getConversationsInternal user mids mstart msize - flip ConversationList more <$> mapM (Mapping.conversationView user) cs + Sem r (Public.ConversationList Public.Conversation) +getConversations luser mids mstart msize = do + ConversationList cs more <- getConversationsInternal luser mids mstart msize + flip ConversationList more <$> mapM (Mapping.conversationView luser) cs getConversationsInternal :: Members '[ConversationStore, ListItems LegacyPaging ConvId] r => - UserId -> + Local UserId -> Maybe (Range 1 32 (CommaSeparatedList ConvId)) -> Maybe ConvId -> Maybe (Range 1 500 Int32) -> - Galley r (Public.ConversationList Data.Conversation) -getConversationsInternal user mids mstart msize = do - (more, ids) <- liftSem $ getIds mids + Sem r (Public.ConversationList Data.Conversation) +getConversationsInternal luser mids mstart msize = do + (more, ids) <- getIds mids let localConvIds = ids cs <- - liftSem (E.getConversations localConvIds) - >>= filterM (liftSem . removeDeleted) - >>= filterM (pure . isMember user . Data.convLocalMembers) + E.getConversations localConvIds + >>= filterM (removeDeleted) + >>= filterM (pure . isMember (tUnqualified luser) . Data.convLocalMembers) pure $ Public.ConversationList cs more where size = fromMaybe (toRange (Proxy @32)) msize @@ -359,10 +360,10 @@ getConversationsInternal user mids mstart msize = do getIds (Just ids) = (False,) <$> E.selectConversations - user + (tUnqualified luser) (fromCommaSeparatedList (fromRange ids)) getIds Nothing = do - r <- E.listItems user mstart (rcast size) + r <- E.listItems (tUnqualified luser) mstart (rcast size) let hasMore = resultSetType r == ResultSetTruncated pure (hasMore, resultSetResult r) @@ -375,25 +376,22 @@ getConversationsInternal user mids mstart msize = do | otherwise = pure True listConversations :: - Members '[ConversationStore, Error InternalError] r => - UserId -> + Members '[ConversationStore, Error InternalError, FederatorAccess, P.TinyLog] r => + Local UserId -> Public.ListConversations -> - Galley r Public.ConversationsResponse -listConversations user (Public.ListConversations ids) = do - luser <- qualifyLocal user - + Sem r Public.ConversationsResponse +listConversations luser (Public.ListConversations ids) = do let (localIds, remoteIds) = partitionQualified luser (fromRange ids) (foundLocalIds, notFoundLocalIds) <- - liftSem $ - foundsAndNotFounds (E.selectConversations user) localIds + foundsAndNotFounds (E.selectConversations (tUnqualified luser)) localIds localInternalConversations <- - liftSem (E.getConversations foundLocalIds) + E.getConversations foundLocalIds >>= filterM removeDeleted - >>= filterM (pure . isMember user . Data.convLocalMembers) - localConversations <- mapM (Mapping.conversationView user) localInternalConversations + >>= filterM (pure . isMember (tUnqualified luser) . Data.convLocalMembers) + localConversations <- mapM (Mapping.conversationView luser) localInternalConversations - (remoteFailures, remoteConversations) <- getRemoteConversationsWithFailures user remoteIds + (remoteFailures, remoteConversations) <- getRemoteConversationsWithFailures luser remoteIds let (failedConvsLocally, failedConvsRemotely) = partitionGetConversationFailures remoteFailures failedConvs = failedConvsLocally <> failedConvsRemotely fetchedOrFailedRemoteIds = Set.fromList $ map Public.cnvQualifiedId remoteConversations <> failedConvs @@ -402,7 +400,7 @@ listConversations user (Public.ListConversations ids) = do -- FUTUREWORK: This implies that the backends are out of sync. Maybe the -- current user should be considered removed from this conversation at this -- point. - Logger.warn $ + P.warn $ Logger.msg ("Some locally found conversation ids were not returned by remotes" :: ByteString) . Logger.field "convIds" (show remoteNotFoundRemoteIds) @@ -420,9 +418,9 @@ listConversations user (Public.ListConversations ids) = do removeDeleted :: Member ConversationStore r => Data.Conversation -> - Galley r Bool + Sem r Bool removeDeleted c - | Data.isConvDeleted c = liftSem $ E.deleteConversation (Data.convId c) >> pure False + | Data.isConvDeleted c = E.deleteConversation (Data.convId c) >> pure False | otherwise = pure True foundsAndNotFounds :: (Monad m, Eq a) => ([a] -> m [a]) -> [a] -> m ([a], [a]) foundsAndNotFounds f xs = do @@ -432,14 +430,14 @@ listConversations user (Public.ListConversations ids) = do iterateConversations :: Members '[ListItems LegacyPaging ConvId, ConversationStore] r => - UserId -> + Local UserId -> Range 1 500 Int32 -> - ([Data.Conversation] -> Galley r a) -> - Galley r [a] -iterateConversations uid pageSize handleConvs = go Nothing + ([Data.Conversation] -> Sem r a) -> + Sem r [a] +iterateConversations luid pageSize handleConvs = go Nothing where go mbConv = do - convResult <- getConversationsInternal uid Nothing mbConv (Just pageSize) + convResult <- getConversationsInternal luid Nothing mbConv (Just pageSize) resultHead <- handleConvs (convList convResult) resultTail <- case convList convResult of (conv : rest) -> @@ -450,29 +448,29 @@ iterateConversations uid pageSize handleConvs = go Nothing pure $ resultHead : resultTail internalGetMemberH :: - Members '[ConversationStore, MemberStore] r => + Members '[ConversationStore, Input (Local ()), MemberStore] r => ConvId ::: UserId -> - Galley r Response + Sem r Response internalGetMemberH (cnv ::: usr) = do - json <$> getLocalSelf usr cnv + lusr <- qualifyLocal usr + json <$> getLocalSelf lusr cnv getLocalSelf :: Members '[ConversationStore, MemberStore] r => - UserId -> + Local UserId -> ConvId -> - Galley r (Maybe Public.Member) -getLocalSelf usr cnv = do - lusr <- qualifyLocal usr - liftSem $ do + Sem r (Maybe Public.Member) +getLocalSelf lusr cnv = do + do alive <- E.isConversationAlive cnv if alive - then Mapping.localMemberToSelf lusr <$$> E.getLocalMember cnv usr + then Mapping.localMemberToSelf lusr <$$> E.getLocalMember cnv (tUnqualified lusr) else Nothing <$ E.deleteConversation cnv getConversationMetaH :: Member ConversationStore r => ConvId -> - Galley r Response + Sem r Response getConversationMetaH cnv = do getConversationMeta cnv <&> \case Nothing -> setStatus status404 empty @@ -481,8 +479,8 @@ getConversationMetaH cnv = do getConversationMeta :: Member ConversationStore r => ConvId -> - Galley r (Maybe ConversationMetadata) -getConversationMeta cnv = liftSem $ do + Sem r (Maybe ConversationMetadata) +getConversationMeta cnv = do alive <- E.isConversationAlive cnv if alive then E.getConversationMetadata cnv @@ -495,21 +493,19 @@ getConversationByReusableCode :: '[ BrigAccess, CodeStore, ConversationStore, - Error ActionError, Error CodeError, Error ConversationError, - Error FederationError, Error NotATeamMember, TeamStore ] r => - UserId -> + Local UserId -> Key -> Value -> - Galley r ConversationCoverView -getConversationByReusableCode zusr key value = do + Sem r ConversationCoverView +getConversationByReusableCode lusr key value = do c <- verifyReusableCode (ConversationCode key value Nothing) - conv <- ensureConversationAccess zusr (Data.codeConversation c) CodeAccess + conv <- ensureConversationAccess (tUnqualified lusr) (Data.codeConversation c) CodeAccess pure $ coverView conv where coverView :: Data.Conversation -> ConversationCoverView diff --git a/services/galley/src/Galley/API/Teams.hs b/services/galley/src/Galley/API/Teams.hs index f73b5e2ebe2..ce9b1ef65ba 100644 --- a/services/galley/src/Galley/API/Teams.hs +++ b/services/galley/src/Galley/API/Teams.hs @@ -76,7 +76,7 @@ import Data.Misc (HttpsUrl, mkHttpsUrl) import Data.Qualified import Data.Range as Range import qualified Data.Set as Set -import Data.Time.Clock (UTCTime (..), getCurrentTime) +import Data.Time.Clock (UTCTime) import qualified Data.UUID as UUID import qualified Data.UUID.Util as UUID import Galley.API.Error as Galley @@ -97,16 +97,16 @@ import qualified Galley.Effects.LegalHoldStore as Data import qualified Galley.Effects.ListItems as E import qualified Galley.Effects.MemberStore as E import qualified Galley.Effects.Paging as E +import qualified Galley.Effects.Queue as E import qualified Galley.Effects.SearchVisibilityStore as SearchVisibilityData import qualified Galley.Effects.SparAccess as Spar import qualified Galley.Effects.TeamFeatureStore as TeamFeatures import qualified Galley.Effects.TeamMemberStore as E import qualified Galley.Effects.TeamStore as E +import Galley.Effects.WaiRoutes import qualified Galley.Intra.Journal as Journal import Galley.Intra.Push import Galley.Options -import qualified Galley.Options as Opts -import qualified Galley.Queue as Q import Galley.Types (UserIdList (UserIdList)) import qualified Galley.Types as Conv import Galley.Types.Conversations.Roles as Roles @@ -121,6 +121,10 @@ import Network.Wai.Predicate hiding (Error, or, result, setStatus) import Network.Wai.Utilities hiding (Error) import Polysemy import Polysemy.Error +import Polysemy.Final +import Polysemy.Input +import Polysemy.Output +import qualified Polysemy.TinyLog as P import qualified SAML2.WebSSO as SAML import qualified System.Logger.Class as Log import qualified Wire.API.Conversation.Role as Public @@ -140,58 +144,61 @@ import Wire.API.User.Identity (UserSSOId (UserSSOId)) import Wire.API.User.RichInfo (RichInfo) getTeamH :: - Members '[Error TeamError, Error NotATeamMember, TeamStore] r => + Members '[Error TeamError, Queue DeleteItem, TeamStore] r => UserId ::: TeamId ::: JSON -> - Galley r Response + Sem r Response getTeamH (zusr ::: tid ::: _) = - maybe (liftSem (throw TeamNotFound)) (pure . json) =<< lookupTeam zusr tid + maybe (throw TeamNotFound) (pure . json) =<< lookupTeam zusr tid getTeamInternalH :: - Members '[Error TeamError, Error NotATeamMember, TeamStore] r => + Members '[Error TeamError, TeamStore] r => TeamId ::: JSON -> - Galley r Response + Sem r Response getTeamInternalH (tid ::: _) = - liftSem . fmap json $ + fmap json $ E.getTeam tid >>= note TeamNotFound getTeamNameInternalH :: - Members '[Error TeamError, Error NotATeamMember, TeamStore] r => + Members '[Error TeamError, TeamStore] r => TeamId ::: JSON -> - Galley r Response + Sem r Response getTeamNameInternalH (tid ::: _) = - liftSem . fmap json $ + fmap json $ getTeamNameInternal tid >>= note TeamNotFound getTeamNameInternal :: Member TeamStore r => TeamId -> Sem r (Maybe TeamName) getTeamNameInternal = fmap (fmap TeamName) . E.getTeamName getManyTeamsH :: - (Members '[TeamStore, ListItems LegacyPaging TeamId] r) => + (Members '[TeamStore, Queue DeleteItem, ListItems LegacyPaging TeamId] r) => UserId ::: Maybe (Either (Range 1 32 (List TeamId)) TeamId) ::: Range 1 100 Int32 ::: JSON -> - Galley r Response + Sem r Response getManyTeamsH (zusr ::: range ::: size ::: _) = json <$> getManyTeams zusr range size getManyTeams :: - (Members '[TeamStore, ListItems LegacyPaging TeamId] r) => + (Members '[TeamStore, Queue DeleteItem, ListItems LegacyPaging TeamId] r) => UserId -> Maybe (Either (Range 1 32 (List TeamId)) TeamId) -> Range 1 100 Int32 -> - Galley r Public.TeamList + Sem r Public.TeamList getManyTeams zusr range size = withTeamIds zusr range size $ \more ids -> do teams <- mapM (lookupTeam zusr) ids pure (Public.newTeamList (catMaybes teams) more) -lookupTeam :: Member TeamStore r => UserId -> TeamId -> Galley r (Maybe Public.Team) +lookupTeam :: + Members '[TeamStore, Queue DeleteItem] r => + UserId -> + TeamId -> + Sem r (Maybe Public.Team) lookupTeam zusr tid = do - tm <- liftSem $ E.getTeamMember tid zusr + tm <- E.getTeamMember tid zusr if isJust tm then do - t <- liftSem $ E.getTeam tid + t <- E.getTeam tid when (Just PendingDelete == (tdStatus <$> t)) $ do - q <- view deleteQueue - void $ Q.tryPush q (TeamItem tid zusr Nothing) + void $ E.tryPush (TeamItem tid zusr Nothing) pure (tdTeam <$> t) else pure Nothing @@ -199,15 +206,16 @@ createNonBindingTeamH :: Members '[ BrigAccess, Error ActionError, - Error InvalidInput, Error TeamError, - Error NotATeamMember, GundeckAccess, - TeamStore + Input UTCTime, + P.TinyLog, + TeamStore, + WaiRoutes ] r => UserId ::: ConnId ::: JsonRequest Public.NonBindingNewTeam ::: JSON -> - Galley r Response + Sem r Response createNonBindingTeamH (zusr ::: zcon ::: req ::: _) = do newTeam <- fromJsonBody req newTeamId <- createNonBindingTeam zusr zcon newTeam @@ -218,15 +226,16 @@ createNonBindingTeam :: '[ BrigAccess, Error ActionError, Error TeamError, - Error NotATeamMember, GundeckAccess, - TeamStore + Input UTCTime, + TeamStore, + P.TinyLog ] r => UserId -> ConnId -> Public.NonBindingNewTeam -> - Galley r TeamId + Sem r TeamId createNonBindingTeam zusr zcon (Public.NonBindingNewTeam body) = do let owner = Public.TeamMember zusr fullPermissions Nothing LH.defUserLegalHoldStatus let others = @@ -236,41 +245,39 @@ createNonBindingTeam zusr zcon (Public.NonBindingNewTeam body) = do let zothers = map (view userId) others ensureUnboundUsers (zusr : zothers) ensureConnectedToLocals zusr zothers - Log.debug $ + P.debug $ Log.field "targets" (toByteString . show $ toByteString <$> zothers) . Log.field "action" (Log.val "Teams.createNonBindingTeam") team <- - liftSem $ - E.createTeam - Nothing - zusr - (body ^. newTeamName) - (body ^. newTeamIcon) - (body ^. newTeamIconKey) - NonBinding + E.createTeam + Nothing + zusr + (body ^. newTeamName) + (body ^. newTeamIcon) + (body ^. newTeamIconKey) + NonBinding finishCreateTeam team owner others (Just zcon) pure (team ^. teamId) createBindingTeamH :: - Members '[BrigAccess, Error InvalidInput, GundeckAccess, TeamStore] r => + Members '[GundeckAccess, Input UTCTime, TeamStore, WaiRoutes] r => UserId ::: TeamId ::: JsonRequest BindingNewTeam ::: JSON -> - Galley r Response + Sem r Response createBindingTeamH (zusr ::: tid ::: req ::: _) = do newTeam <- fromJsonBody req newTeamId <- createBindingTeam zusr tid newTeam pure (empty & setStatus status201 . location newTeamId) createBindingTeam :: - Members '[BrigAccess, GundeckAccess, TeamStore] r => + Members '[GundeckAccess, Input UTCTime, TeamStore] r => UserId -> TeamId -> BindingNewTeam -> - Galley r TeamId + Sem r TeamId createBindingTeam zusr tid (BindingNewTeam body) = do let owner = Public.TeamMember zusr fullPermissions Nothing LH.defUserLegalHoldStatus team <- - liftSem $ - E.createTeam (Just tid) zusr (body ^. newTeamName) (body ^. newTeamIcon) (body ^. newTeamIconKey) Binding + E.createTeam (Just tid) zusr (body ^. newTeamName) (body ^. newTeamIcon) (body ^. newTeamIconKey) Binding finishCreateTeam team owner [] Nothing pure tid @@ -278,65 +285,76 @@ updateTeamStatusH :: Members '[ BrigAccess, Error ActionError, - Error InvalidInput, Error TeamError, - Error NotATeamMember, - TeamStore + Input Opts, + Input UTCTime, + P.TinyLog, + TeamStore, + WaiRoutes ] r => TeamId ::: JsonRequest TeamStatusUpdate ::: JSON -> - Galley r Response + Sem r Response updateTeamStatusH (tid ::: req ::: _) = do teamStatusUpdate <- fromJsonBody req updateTeamStatus tid teamStatusUpdate return empty updateTeamStatus :: - Members '[BrigAccess, Error ActionError, Error TeamError, Error NotATeamMember, TeamStore] r => + Members + '[ BrigAccess, + Error ActionError, + Error TeamError, + Input Opts, + Input UTCTime, + P.TinyLog, + TeamStore + ] + r => TeamId -> TeamStatusUpdate -> - Galley r () + Sem r () updateTeamStatus tid (TeamStatusUpdate newStatus cur) = do - oldStatus <- tdStatus <$> liftSem (E.getTeam tid >>= note TeamNotFound) + oldStatus <- fmap tdStatus $ E.getTeam tid >>= note TeamNotFound valid <- validateTransition (oldStatus, newStatus) when valid $ do journal newStatus cur - liftSem $ E.setTeamStatus tid newStatus + E.setTeamStatus tid newStatus where journal Suspended _ = Journal.teamSuspend tid journal Active c = do - teamCreationTime <- liftSem $ E.getTeamCreationTime tid + teamCreationTime <- E.getTeamCreationTime tid -- When teams are created, they are activated immediately. In this situation, Brig will -- most likely report team size as 0 due to ES taking some time to index the team creator. -- This is also very difficult to test, so is not tested. - (TeamSize possiblyStaleSize) <- liftSem $ E.getSize tid + (TeamSize possiblyStaleSize) <- E.getSize tid let size = if possiblyStaleSize == 0 then 1 else possiblyStaleSize Journal.teamActivate tid size c teamCreationTime - journal _ _ = liftSem $ throw InvalidTeamStatusUpdate - validateTransition :: Member (Error ActionError) r => (TeamStatus, TeamStatus) -> Galley r Bool + journal _ _ = throw InvalidTeamStatusUpdate + validateTransition :: Member (Error ActionError) r => (TeamStatus, TeamStatus) -> Sem r Bool validateTransition = \case (PendingActive, Active) -> return True (Active, Active) -> return False (Active, Suspended) -> return True (Suspended, Active) -> return True (Suspended, Suspended) -> return False - (_, _) -> liftSem $ throw InvalidTeamStatusUpdate + (_, _) -> throw InvalidTeamStatusUpdate updateTeamH :: Members '[ Error ActionError, - Error InvalidInput, - Error TeamError, Error NotATeamMember, GundeckAccess, - TeamStore + Input UTCTime, + TeamStore, + WaiRoutes ] r => UserId ::: ConnId ::: TeamId ::: JsonRequest Public.TeamUpdateData ::: JSON -> - Galley r Response + Sem r Response updateTeamH (zusr ::: zcon ::: tid ::: req ::: _) = do updateData <- fromJsonBody req updateTeam zusr zcon tid updateData @@ -345,9 +363,9 @@ updateTeamH (zusr ::: zcon ::: tid ::: req ::: _) = do updateTeam :: Members '[ Error ActionError, - Error TeamError, Error NotATeamMember, GundeckAccess, + Input UTCTime, TeamStore ] r => @@ -355,20 +373,20 @@ updateTeam :: ConnId -> TeamId -> Public.TeamUpdateData -> - Galley r () + Sem r () updateTeam zusr zcon tid updateData = do - zusrMembership <- liftSem $ E.getTeamMember tid zusr + zusrMembership <- E.getTeamMember tid zusr -- let zothers = map (view userId) membs -- Log.debug $ -- Log.field "targets" (toByteString . show $ toByteString <$> zothers) -- . Log.field "action" (Log.val "Teams.updateTeam") void $ permissionCheck SetTeamData zusrMembership - liftSem $ E.setTeamData tid updateData - now <- liftIO getCurrentTime + E.setTeamData tid updateData + now <- input memList <- getTeamMembersForFanout tid let e = newEvent TeamUpdate tid now & eventData .~ Just (EdTeamUpdate updateData) let r = list1 (userRecipient zusr) (membersToRecipients (Just zusr) (memList ^. teamMembers)) - liftSem . E.push1 $ newPushLocal1 (memList ^. teamMemberListType) zusr (TeamEvent e) r & pushConn .~ Just zcon + E.push1 $ newPushLocal1 (memList ^. teamMemberListType) zusr (TeamEvent e) r & pushConn .~ Just zcon deleteTeamH :: Members @@ -379,11 +397,13 @@ deleteTeamH :: Error InvalidInput, Error TeamError, Error NotATeamMember, - TeamStore + Queue DeleteItem, + TeamStore, + WaiRoutes ] r => UserId ::: ConnId ::: TeamId ::: OptionalJsonRequest Public.TeamDeleteData ::: JSON -> - Galley r Response + Sem r Response deleteTeamH (zusr ::: zcon ::: tid ::: req ::: _) = do mBody <- fromOptionalJsonBody req deleteTeam zusr zcon tid mBody @@ -399,6 +419,7 @@ deleteTeam :: Error InvalidInput, Error TeamError, Error NotATeamMember, + Queue DeleteItem, TeamStore ] r => @@ -406,11 +427,11 @@ deleteTeam :: ConnId -> TeamId -> Maybe Public.TeamDeleteData -> - Galley r () + Sem r () deleteTeam zusr zcon tid mBody = do - team <- liftSem $ E.getTeam tid >>= note TeamNotFound + team <- E.getTeam tid >>= note TeamNotFound case tdStatus team of - Deleted -> liftSem $ throw TeamNotFound + Deleted -> throw TeamNotFound PendingDelete -> queueTeamDeletion tid zusr (Just zcon) _ -> do @@ -418,24 +439,30 @@ deleteTeam zusr zcon tid mBody = do queueTeamDeletion tid zusr (Just zcon) where checkPermissions team = do - void $ permissionCheck DeleteTeam =<< liftSem (E.getTeamMember tid zusr) + void $ permissionCheck DeleteTeam =<< E.getTeamMember tid zusr when ((tdTeam team) ^. teamBinding == Binding) $ do - body <- liftSem $ mBody & note (InvalidPayload "missing request body") + body <- mBody & note (InvalidPayload "missing request body") ensureReAuthorised zusr (body ^. tdAuthPassword) -- This can be called by stern internalDeleteBindingTeamWithOneMember :: - Members '[Error InternalError, Error TeamError, Error NotATeamMember, TeamStore] r => + Members + '[ Error InternalError, + Error TeamError, + Queue DeleteItem, + TeamStore + ] + r => TeamId -> - Galley r () + Sem r () internalDeleteBindingTeamWithOneMember tid = do - team <- liftSem (E.getTeam tid) - liftSem . unless ((view teamBinding . tdTeam <$> team) == Just Binding) $ + team <- E.getTeam tid + unless ((view teamBinding . tdTeam <$> team) == Just Binding) $ throw NoBindingTeam - mems <- liftSem $ E.getTeamMembersWithLimit tid (unsafeRange 2) + mems <- E.getTeamMembersWithLimit tid (unsafeRange 2) case mems ^. teamMembers of (mem : []) -> queueTeamDeletion tid (mem ^. userId) Nothing - _ -> liftSem $ throw NotAOneMemberTeam + _ -> throw NotAOneMemberTeam -- This function is "unchecked" because it does not validate that the user has the `DeleteTeam` permission. uncheckedDeleteTeam :: @@ -444,167 +471,155 @@ uncheckedDeleteTeam :: '[ BrigAccess, ExternalAccess, GundeckAccess, + Input Opts, + Input UTCTime, LegalHoldStore, MemberStore, SparAccess, TeamStore ] r => - UserId -> + Local UserId -> Maybe ConnId -> TeamId -> - Galley r () -uncheckedDeleteTeam zusr zcon tid = do - team <- liftSem $ E.getTeam tid + Sem r () +uncheckedDeleteTeam lusr zcon tid = do + team <- E.getTeam tid when (isJust team) $ do - liftSem $ Spar.deleteTeam tid - now <- liftIO getCurrentTime + Spar.deleteTeam tid + now <- input convs <- - liftSem $ - filter (not . view managedConversation) <$> E.getTeamConversations tid + filter (not . view managedConversation) <$> E.getTeamConversations tid -- Even for LARGE TEAMS, we _DO_ want to fetch all team members here because we -- want to generate conversation deletion events for non-team users. This should -- be fine as it is done once during the life team of a team and we still do not -- fanout this particular event to all team members anyway. And this is anyway -- done asynchronously - membs <- liftSem $ E.getTeamMembers tid + membs <- E.getTeamMembers tid (ue, be) <- foldrM (createConvDeleteEvents now membs) ([], []) convs let e = newEvent TeamDelete tid now pushDeleteEvents membs e ue - liftSem $ E.deliverAsync be + E.deliverAsync be -- TODO: we don't delete bots here, but we should do that, since -- every bot user can only be in a single conversation. Just -- deleting conversations from the database is not enough. when ((view teamBinding . tdTeam <$> team) == Just Binding) $ do - liftSem $ mapM_ (E.deleteUser . view userId) membs + mapM_ (E.deleteUser . view userId) membs Journal.teamDelete tid - liftSem $ Data.unsetTeamLegalholdWhitelisted tid - liftSem $ E.deleteTeam tid + Data.unsetTeamLegalholdWhitelisted tid + E.deleteTeam tid where - pushDeleteEvents :: [TeamMember] -> Event -> [Push] -> Galley r () + pushDeleteEvents :: [TeamMember] -> Event -> [Push] -> Sem r () pushDeleteEvents membs e ue = do - o <- view $ options . optSettings - let r = list1 (userRecipient zusr) (membersToRecipients (Just zusr) membs) + o <- inputs (view optSettings) + let r = list1 (userRecipient (tUnqualified lusr)) (membersToRecipients (Just (tUnqualified lusr)) membs) -- To avoid DoS on gundeck, send team deletion events in chunks let chunkSize = fromMaybe defConcurrentDeletionEvents (o ^. setConcurrentDeletionEvents) let chunks = List.chunksOf chunkSize (toList r) - liftSem $ - forM_ chunks $ \chunk -> case chunk of - [] -> return () - -- push TeamDelete events. Note that despite having a complete list, we are guaranteed in the - -- push module to never fan this out to more than the limit - x : xs -> E.push1 (newPushLocal1 ListComplete zusr (TeamEvent e) (list1 x xs) & pushConn .~ zcon) + forM_ chunks $ \chunk -> case chunk of + [] -> return () + -- push TeamDelete events. Note that despite having a complete list, we are guaranteed in the + -- push module to never fan this out to more than the limit + x : xs -> E.push1 (newPushLocal1 ListComplete (tUnqualified lusr) (TeamEvent e) (list1 x xs) & pushConn .~ zcon) -- To avoid DoS on gundeck, send conversation deletion events slowly - -- FUTUREWORK: make this behaviour part of the GundeckAccess effect - let delay = 1000 * (fromMaybe defDeleteConvThrottleMillis (o ^. setDeleteConvThrottleMillis)) - forM_ ue $ \event -> do - -- push ConversationDelete events - liftSem $ E.push1 event - threadDelay delay + E.pushSlowly ue createConvDeleteEvents :: UTCTime -> [TeamMember] -> TeamConversation -> ([Push], [(BotMember, Conv.Event)]) -> - Galley r ([Push], [(BotMember, Conv.Event)]) + Sem r ([Push], [(BotMember, Conv.Event)]) createConvDeleteEvents now teamMembs c (pp, ee) = do - localDomain <- viewFederationDomain - let qconvId = Qualified (c ^. conversationId) localDomain - qorig = Qualified zusr localDomain - (bots, convMembs) <- liftSem $ localBotsAndUsers <$> E.getLocalMembers (c ^. conversationId) + let qconvId = qUntagged $ qualifyAs lusr (c ^. conversationId) + (bots, convMembs) <- localBotsAndUsers <$> E.getLocalMembers (c ^. conversationId) -- Only nonTeamMembers need to get any events, since on team deletion, -- all team users are deleted immediately after these events are sent -- and will thus never be able to see these events in practice. let mm = nonTeamMembers convMembs teamMembs - let e = Conv.Event Conv.ConvDelete qconvId qorig now Conv.EdConvDelete + let e = Conv.Event Conv.ConvDelete qconvId (qUntagged lusr) now Conv.EdConvDelete -- This event always contains all the required recipients - let p = newPushLocal ListComplete zusr (ConvEvent e) (map recipient mm) + let p = newPushLocal ListComplete (tUnqualified lusr) (ConvEvent e) (map recipient mm) let ee' = bots `zip` repeat e let pp' = maybe pp (\x -> (x & pushConn .~ zcon) : pp) p pure (pp', ee' ++ ee) getTeamConversationRoles :: - Members '[Error TeamError, Error NotATeamMember, TeamStore] r => + Members '[Error NotATeamMember, TeamStore] r => UserId -> TeamId -> - Galley r Public.ConversationRolesList + Sem r Public.ConversationRolesList getTeamConversationRoles zusr tid = do - liftSem . void $ E.getTeamMember tid zusr >>= noteED @NotATeamMember + void $ E.getTeamMember tid zusr >>= noteED @NotATeamMember -- NOTE: If/when custom roles are added, these roles should -- be merged with the team roles (if they exist) pure $ Public.ConversationRolesList wireConvRoles getTeamMembersH :: - Members '[Error TeamError, Error NotATeamMember, TeamStore] r => + Members '[Error NotATeamMember, TeamStore] r => UserId ::: TeamId ::: Range 1 Public.HardTruncationLimit Int32 ::: JSON -> - Galley r Response + Sem r Response getTeamMembersH (zusr ::: tid ::: maxResults ::: _) = do (memberList, withPerms) <- getTeamMembers zusr tid maxResults pure . json $ teamMemberListJson withPerms memberList getTeamMembers :: - Members '[Error TeamError, Error NotATeamMember, TeamStore] r => + Members '[Error NotATeamMember, TeamStore] r => UserId -> TeamId -> Range 1 Public.HardTruncationLimit Int32 -> - Galley r (Public.TeamMemberList, Public.TeamMember -> Bool) -getTeamMembers zusr tid maxResults = liftSem $ do + Sem r (Public.TeamMemberList, Public.TeamMember -> Bool) +getTeamMembers zusr tid maxResults = do m <- E.getTeamMember tid zusr >>= noteED @NotATeamMember mems <- E.getTeamMembersWithLimit tid maxResults let withPerms = (m `canSeePermsOf`) pure (mems, withPerms) +outputToStreamingBody :: Member (Final IO) r => Sem (Output LByteString ': r) () -> Sem r StreamingBody +outputToStreamingBody action = withWeavingToFinal @IO $ \state weave _inspect -> + pure . (<$ state) $ \write flush -> do + let writeChunk c = embedFinal $ do + write (lazyByteString c) + flush + void . weave . (<$ state) $ runOutputSem writeChunk action + getTeamMembersCSVH :: - (Members '[BrigAccess, Error ActionError, TeamStore] r) => + (Members '[BrigAccess, Error ActionError, TeamMemberStore InternalPaging, TeamStore, Final IO] r) => UserId ::: TeamId ::: JSON -> - Galley r Response + Sem r Response getTeamMembersCSVH (zusr ::: tid ::: _) = do - liftSem $ - E.getTeamMember tid zusr >>= \case - Nothing -> throw AccessDenied - Just member -> unless (member `hasPermission` DownloadTeamMembersCsv) $ throw AccessDenied + E.getTeamMember tid zusr >>= \case + Nothing -> throw AccessDenied + Just member -> unless (member `hasPermission` DownloadTeamMembersCsv) $ throw AccessDenied - env <- ask -- In case an exception is thrown inside the StreamingBody of responseStream -- the response will not contain a correct error message, but rather be an -- http error such as 'InvalidChunkHeaders'. The exception however still -- reaches the middleware and is being tracked in logging and metrics. - -- - -- FUTUREWORK: rewrite this using some streaming primitive (e.g. polysemy's Input) + body <- outputToStreamingBody $ do + output headerLine + E.withChunks (\mps -> E.listTeamMembers @InternalPaging tid mps maxBound) $ + \members -> do + inviters <- lookupInviterHandle members + users <- + lookupUser <$> E.lookupActivatedUsers (fmap (view userId) members) + richInfos <- + lookupRichInfo <$> E.getRichInfoMultiUser (fmap (view userId) members) + output @LByteString + ( encodeDefaultOrderedByNameWith + defaultEncodeOptions + (mapMaybe (teamExportUser users inviters richInfos) members) + ) pure $ responseStream status200 [ (hContentType, "text/csv"), ("Content-Disposition", "attachment; filename=\"wire_team_members.csv\"") ] - $ \write flush -> do - let writeString = write . lazyByteString - writeString headerLine - flush - evalGalley env $ do - E.withChunks pager $ - \members -> do - inviters <- lookupInviterHandle members - users <- - liftSem $ - lookupUser <$> E.lookupActivatedUsers (fmap (view userId) members) - richInfos <- - liftSem $ - lookupRichInfo <$> E.getRichInfoMultiUser (fmap (view userId) members) - liftIO $ do - writeString - ( encodeDefaultOrderedByNameWith - defaultEncodeOptions - (mapMaybe (teamExportUser users inviters richInfos) members) - ) - flush + body where headerLine :: LByteString headerLine = encodeDefaultOrderedByNameWith (defaultEncodeOptions {encIncludeHeader = True}) ([] :: [TeamExportUser]) - pager :: Maybe (InternalPagingState TeamMember) -> Galley GalleyEffects (InternalPage TeamMember) - pager mps = liftSem $ E.listTeamMembers tid mps maxBound - defaultEncodeOptions :: EncodeOptions defaultEncodeOptions = EncodeOptions @@ -639,12 +654,12 @@ getTeamMembersCSVH (zusr ::: tid ::: _) = do tExportUserId = U.userId user } - lookupInviterHandle :: Member BrigAccess r => [TeamMember] -> Galley r (UserId -> Maybe Handle.Handle) + lookupInviterHandle :: Member BrigAccess r => [TeamMember] -> Sem r (UserId -> Maybe Handle.Handle) lookupInviterHandle members = do let inviterIds :: [UserId] inviterIds = nub $ catMaybes $ fmap fst . view invitation <$> members - userList :: [User] <- liftSem $ accountUser <$$> E.getUsers inviterIds + userList :: [User] <- accountUser <$$> E.getUsers inviterIds let userMap :: M.Map UserId Handle.Handle userMap = M.fromList . catMaybes $ extract <$> userList @@ -673,15 +688,14 @@ getTeamMembersCSVH (zusr ::: tid ::: _) = do bulkGetTeamMembersH :: Members - '[ Error ActionError, - Error InvalidInput, - Error TeamError, + '[ Error InvalidInput, Error NotATeamMember, - TeamStore + TeamStore, + WaiRoutes ] r => UserId ::: TeamId ::: Range 1 Public.HardTruncationLimit Int32 ::: JsonRequest Public.UserIdList ::: JSON -> - Galley r Response + Sem r Response bulkGetTeamMembersH (zusr ::: tid ::: maxResults ::: body ::: _) = do UserIdList uids <- fromJsonBody body (memberList, withPerms) <- bulkGetTeamMembers zusr tid maxResults uids @@ -689,13 +703,13 @@ bulkGetTeamMembersH (zusr ::: tid ::: maxResults ::: body ::: _) = do -- | like 'getTeamMembers', but with an explicit list of users we are to return. bulkGetTeamMembers :: - Members '[Error ActionError, Error InvalidInput, Error TeamError, Error NotATeamMember, TeamStore] r => + Members '[Error InvalidInput, Error NotATeamMember, TeamStore] r => UserId -> TeamId -> Range 1 HardTruncationLimit Int32 -> [UserId] -> - Galley r (TeamMemberList, TeamMember -> Bool) -bulkGetTeamMembers zusr tid maxResults uids = liftSem $ do + Sem r (TeamMemberList, TeamMember -> Bool) +bulkGetTeamMembers zusr tid maxResults uids = do unless (length uids <= fromIntegral (fromRange maxResults)) $ throw BulkGetMemberLimitExceeded m <- E.getTeamMember tid zusr >>= noteED @NotATeamMember @@ -707,7 +721,7 @@ bulkGetTeamMembers zusr tid maxResults uids = liftSem $ do getTeamMemberH :: Members '[Error TeamError, Error NotATeamMember, TeamStore] r => UserId ::: TeamId ::: UserId ::: JSON -> - Galley r Response + Sem r Response getTeamMemberH (zusr ::: tid ::: uid ::: _) = do (member, withPerms) <- getTeamMember zusr tid uid pure . json $ teamMemberJson withPerms member @@ -717,43 +731,48 @@ getTeamMember :: UserId -> TeamId -> UserId -> - Galley r (Public.TeamMember, Public.TeamMember -> Bool) + Sem r (Public.TeamMember, Public.TeamMember -> Bool) getTeamMember zusr tid uid = do m <- - liftSem $ - E.getTeamMember tid zusr - >>= noteED @NotATeamMember + E.getTeamMember tid zusr + >>= noteED @NotATeamMember let withPerms = (m `canSeePermsOf`) - member <- liftSem $ E.getTeamMember tid uid >>= note TeamMemberNotFound + member <- E.getTeamMember tid uid >>= note TeamMemberNotFound pure (member, withPerms) internalDeleteBindingTeamWithOneMemberH :: - Members '[Error InternalError, Error TeamError, Error NotATeamMember, TeamStore] r => + Members + '[ Error InternalError, + Error TeamError, + Queue DeleteItem, + TeamStore + ] + r => TeamId -> - Galley r Response + Sem r Response internalDeleteBindingTeamWithOneMemberH tid = do internalDeleteBindingTeamWithOneMember tid pure (empty & setStatus status202) uncheckedGetTeamMemberH :: - Members '[Error TeamError, Error NotATeamMember, TeamStore] r => + Members '[Error TeamError, TeamStore] r => TeamId ::: UserId ::: JSON -> - Galley r Response + Sem r Response uncheckedGetTeamMemberH (tid ::: uid ::: _) = do json <$> uncheckedGetTeamMember tid uid uncheckedGetTeamMember :: - Members '[Error TeamError, Error NotATeamMember, TeamStore] r => + Members '[Error TeamError, TeamStore] r => TeamId -> UserId -> - Galley r TeamMember + Sem r TeamMember uncheckedGetTeamMember tid uid = - liftSem $ E.getTeamMember tid uid >>= note TeamMemberNotFound + E.getTeamMember tid uid >>= note TeamMemberNotFound uncheckedGetTeamMembersH :: Member TeamStore r => TeamId ::: Range 1 HardTruncationLimit Int32 ::: JSON -> - Galley r Response + Sem r Response uncheckedGetTeamMembersH (tid ::: maxResults ::: _) = do json <$> uncheckedGetTeamMembers tid maxResults @@ -761,8 +780,8 @@ uncheckedGetTeamMembers :: Member TeamStore r => TeamId -> Range 1 HardTruncationLimit Int32 -> - Galley r TeamMemberList -uncheckedGetTeamMembers tid maxResults = liftSem $ E.getTeamMembersWithLimit tid maxResults + Sem r TeamMemberList +uncheckedGetTeamMembers tid maxResults = E.getTeamMembersWithLimit tid maxResults addTeamMemberH :: Members @@ -770,18 +789,22 @@ addTeamMemberH :: GundeckAccess, Error ActionError, Error LegalHoldError, - Error InvalidInput, Error TeamError, Error NotATeamMember, + Input (Local ()), + Input Opts, + Input UTCTime, LegalHoldStore, MemberStore, + P.TinyLog, TeamFeatureStore, TeamNotificationStore, - TeamStore + TeamStore, + WaiRoutes ] r => UserId ::: ConnId ::: TeamId ::: JsonRequest Public.NewTeamMember ::: JSON -> - Galley r Response + Sem r Response addTeamMemberH (zusr ::: zcon ::: tid ::: req ::: _) = do nmem <- fromJsonBody req addTeamMember zusr zcon tid nmem @@ -795,33 +818,37 @@ addTeamMember :: Error LegalHoldError, Error TeamError, Error NotATeamMember, + Input (Local ()), + Input Opts, + Input UTCTime, LegalHoldStore, MemberStore, TeamFeatureStore, TeamNotificationStore, - TeamStore + TeamStore, + P.TinyLog ] r => UserId -> ConnId -> TeamId -> Public.NewTeamMember -> - Galley r () + Sem r () addTeamMember zusr zcon tid nmem = do let uid = nmem ^. ntmNewTeamMember . userId - Log.debug $ + P.debug $ Log.field "targets" (toByteString uid) . Log.field "action" (Log.val "Teams.addTeamMember") -- verify permissions zusrMembership <- - liftSem (E.getTeamMember tid zusr) + E.getTeamMember tid zusr >>= permissionCheck AddTeamMember let targetPermissions = nmem ^. ntmNewTeamMember . permissions targetPermissions `ensureNotElevated` zusrMembership ensureNonBindingTeam tid ensureUnboundUsers [uid] ensureConnectedToLocals zusr [uid] - (TeamSize sizeBeforeJoin) <- liftSem $ E.getSize tid + (TeamSize sizeBeforeJoin) <- E.getSize tid ensureNotTooLargeForLegalHold tid (fromIntegral sizeBeforeJoin + 1) memList <- getTeamMembersForFanout tid void $ addTeamMemberInternal tid (Just zusr) (Just zcon) nmem memList @@ -831,19 +858,22 @@ uncheckedAddTeamMemberH :: Members '[ BrigAccess, Error LegalHoldError, - Error InvalidInput, Error TeamError, - Error NotATeamMember, GundeckAccess, + Input (Local ()), + Input Opts, + Input UTCTime, LegalHoldStore, MemberStore, + P.TinyLog, TeamFeatureStore, + TeamNotificationStore, TeamStore, - TeamNotificationStore + WaiRoutes ] r => TeamId ::: JsonRequest NewTeamMember ::: JSON -> - Galley r Response + Sem r Response uncheckedAddTeamMemberH (tid ::: req ::: _) = do nmem <- fromJsonBody req uncheckedAddTeamMember tid nmem @@ -855,20 +885,23 @@ uncheckedAddTeamMember :: GundeckAccess, Error LegalHoldError, Error TeamError, - Error NotATeamMember, + Input (Local ()), + Input Opts, + Input UTCTime, MemberStore, LegalHoldStore, + P.TinyLog, TeamFeatureStore, - TeamStore, - TeamNotificationStore + TeamNotificationStore, + TeamStore ] r => TeamId -> NewTeamMember -> - Galley r () + Sem r () uncheckedAddTeamMember tid nmem = do mems <- getTeamMembersForFanout tid - (TeamSize sizeBeforeJoin) <- liftSem $ E.getSize tid + (TeamSize sizeBeforeJoin) <- E.getSize tid ensureNotTooLargeForLegalHold tid (fromIntegral sizeBeforeJoin + 1) (TeamSize sizeBeforeAdd) <- addTeamMemberInternal tid Nothing Nothing nmem mems billingUserIds <- Journal.getBillingUserIds tid $ Just $ newTeamMemberList ((nmem ^. ntmNewTeamMember) : mems ^. teamMembers) (mems ^. teamMemberListType) @@ -878,18 +911,21 @@ updateTeamMemberH :: Members '[ BrigAccess, Error ActionError, - Error InvalidInput, Error TeamError, Error NotATeamMember, + Input Opts, + Input UTCTime, GundeckAccess, - TeamStore + P.TinyLog, + TeamStore, + WaiRoutes ] r => UserId ::: ConnId ::: TeamId ::: JsonRequest Public.NewTeamMember ::: JSON -> - Galley r Response + Sem r Response updateTeamMemberH (zusr ::: zcon ::: tid ::: req ::: _) = do -- the team member to be updated - targetMember <- view ntmNewTeamMember <$> fromJsonBody req + targetMember <- view ntmNewTeamMember <$> (fromJsonBody req) updateTeamMember zusr zcon tid targetMember pure empty @@ -901,6 +937,9 @@ updateTeamMember :: Error TeamError, Error NotATeamMember, GundeckAccess, + Input Opts, + Input UTCTime, + P.TinyLog, TeamStore ] r => @@ -908,33 +947,32 @@ updateTeamMember :: ConnId -> TeamId -> TeamMember -> - Galley r () + Sem r () updateTeamMember zusr zcon tid targetMember = do let targetId = targetMember ^. userId targetPermissions = targetMember ^. permissions - Log.debug $ + P.debug $ Log.field "targets" (toByteString targetId) . Log.field "action" (Log.val "Teams.updateTeamMember") -- get the team and verify permissions - team <- liftSem . fmap tdTeam $ E.getTeam tid >>= note TeamNotFound + team <- fmap tdTeam $ E.getTeam tid >>= note TeamNotFound user <- - liftSem (E.getTeamMember tid zusr) + E.getTeamMember tid zusr >>= permissionCheck SetMemberPermissions -- user may not elevate permissions targetPermissions `ensureNotElevated` user previousMember <- - liftSem $ E.getTeamMember tid targetId >>= note TeamMemberNotFound - liftSem - . when - ( downgradesOwner previousMember targetPermissions - && not (canDowngradeOwner user previousMember) - ) + E.getTeamMember tid targetId >>= note TeamMemberNotFound + when + ( downgradesOwner previousMember targetPermissions + && not (canDowngradeOwner user previousMember) + ) $ throw AccessDenied -- update target in Cassandra - liftSem $ E.setTeamMemberPermissions (previousMember ^. permissions) tid targetId targetPermissions + E.setTeamMemberPermissions (previousMember ^. permissions) tid targetId targetPermissions updatedMembers <- getTeamMembersForFanout tid updateJournal team updatedMembers @@ -947,14 +985,14 @@ updateTeamMember zusr zcon tid targetMember = do permissionsRole (previousMember ^. permissions) == Just RoleOwner && permissionsRole targetPermissions /= Just RoleOwner - updateJournal :: Team -> TeamMemberList -> Galley r () + updateJournal :: Team -> TeamMemberList -> Sem r () updateJournal team mems = do when (team ^. teamBinding == Binding) $ do - (TeamSize size) <- liftSem $ E.getSize tid + (TeamSize size) <- E.getSize tid billingUserIds <- Journal.getBillingUserIds tid $ Just mems Journal.teamUpdate tid size billingUserIds - updatePeers :: UserId -> Permissions -> TeamMemberList -> Galley r () + updatePeers :: UserId -> Permissions -> TeamMemberList -> Sem r () updatePeers targetId targetPermissions updatedMembers = do -- inform members of the team about the change -- some (privileged) users will be informed about which change was applied @@ -962,11 +1000,11 @@ updateTeamMember zusr zcon tid targetMember = do mkUpdate = EdMemberUpdate targetId privilegedUpdate = mkUpdate $ Just targetPermissions privilegedRecipients = membersToRecipients Nothing privileged - now <- liftIO getCurrentTime + now <- input let ePriv = newEvent MemberUpdate tid now & eventData ?~ privilegedUpdate -- push to all members (user is privileged) let pushPriv = newPushLocal (updatedMembers ^. teamMemberListType) zusr (TeamEvent ePriv) $ privilegedRecipients - liftSem $ for_ pushPriv $ \p -> E.push1 $ p & pushConn .~ Just zcon + for_ pushPriv $ \p -> E.push1 $ p & pushConn .~ Just zcon deleteTeamMemberH :: Members @@ -975,19 +1013,25 @@ deleteTeamMemberH :: Error ActionError, Error AuthenticationError, Error InvalidInput, - Error TeamError, Error NotATeamMember, + Error TeamError, ExternalAccess, GundeckAccess, + Input (Local ()), + Input Opts, + Input UTCTime, MemberStore, - TeamStore + P.TinyLog, + TeamStore, + WaiRoutes ] r => UserId ::: ConnId ::: TeamId ::: UserId ::: OptionalJsonRequest Public.TeamMemberDeleteData ::: JSON -> - Galley r Response + Sem r Response deleteTeamMemberH (zusr ::: zcon ::: tid ::: remove ::: req ::: _) = do + lusr <- qualifyLocal zusr mBody <- fromOptionalJsonBody req - deleteTeamMember zusr zcon tid remove mBody >>= \case + deleteTeamMember lusr zcon tid remove mBody >>= \case TeamMemberDeleteAccepted -> pure (empty & setStatus status202) TeamMemberDeleteCompleted -> pure empty @@ -1006,35 +1050,38 @@ deleteTeamMember :: Error TeamError, Error NotATeamMember, ExternalAccess, + Input Opts, + Input UTCTime, GundeckAccess, MemberStore, - TeamStore + TeamStore, + P.TinyLog ] r => - UserId -> + Local UserId -> ConnId -> TeamId -> UserId -> Maybe Public.TeamMemberDeleteData -> - Galley r TeamMemberDeleteResult -deleteTeamMember zusr zcon tid remove mBody = do - Log.debug $ + Sem r TeamMemberDeleteResult +deleteTeamMember lusr zcon tid remove mBody = do + P.debug $ Log.field "targets" (toByteString remove) . Log.field "action" (Log.val "Teams.deleteTeamMember") - zusrMember <- liftSem $ E.getTeamMember tid zusr - targetMember <- liftSem $ E.getTeamMember tid remove + zusrMember <- E.getTeamMember tid (tUnqualified lusr) + targetMember <- E.getTeamMember tid remove void $ permissionCheck RemoveTeamMember zusrMember - liftSem $ do + do dm <- note TeamMemberNotFound zusrMember tm <- note TeamMemberNotFound targetMember unless (canDeleteMember dm tm) $ throw AccessDenied - team <- tdTeam <$> liftSem (E.getTeam tid >>= note TeamNotFound) + team <- fmap tdTeam $ E.getTeam tid >>= note TeamNotFound mems <- getTeamMembersForFanout tid if team ^. teamBinding == Binding && isJust targetMember then do - body <- liftSem $ mBody & note (InvalidPayload "missing request body") - ensureReAuthorised zusr (body ^. tmdAuthPassword) - (TeamSize sizeBeforeDelete) <- liftSem $ E.getSize tid + body <- mBody & note (InvalidPayload "missing request body") + ensureReAuthorised (tUnqualified lusr) (body ^. tmdAuthPassword) + (TeamSize sizeBeforeDelete) <- E.getSize tid -- TeamSize is 'Natural' and subtracting from 0 is an error -- TeamSize could be reported as 0 if team members are added and removed very quickly, -- which happens in tests @@ -1042,80 +1089,80 @@ deleteTeamMember zusr zcon tid remove mBody = do if sizeBeforeDelete == 0 then 0 else sizeBeforeDelete - 1 - liftSem $ E.deleteUser remove + E.deleteUser remove billingUsers <- Journal.getBillingUserIds tid (Just mems) Journal.teamUpdate tid sizeAfterDelete $ filter (/= remove) billingUsers pure TeamMemberDeleteAccepted else do - uncheckedDeleteTeamMember zusr (Just zcon) tid remove mems + uncheckedDeleteTeamMember lusr (Just zcon) tid remove mems pure TeamMemberDeleteCompleted -- This function is "unchecked" because it does not validate that the user has the `RemoveTeamMember` permission. uncheckedDeleteTeamMember :: forall r. Members - '[ BrigAccess, - ConversationStore, + '[ ConversationStore, GundeckAccess, ExternalAccess, + Input UTCTime, MemberStore, TeamStore ] r => - UserId -> + Local UserId -> Maybe ConnId -> TeamId -> UserId -> TeamMemberList -> - Galley r () -uncheckedDeleteTeamMember zusr zcon tid remove mems = do - now <- liftIO getCurrentTime + Sem r () +uncheckedDeleteTeamMember lusr zcon tid remove mems = do + now <- input pushMemberLeaveEvent now - liftSem $ E.deleteTeamMember tid remove + E.deleteTeamMember tid remove removeFromConvsAndPushConvLeaveEvent now where -- notify all team members. - pushMemberLeaveEvent :: UTCTime -> Galley r () + pushMemberLeaveEvent :: UTCTime -> Sem r () pushMemberLeaveEvent now = do let e = newEvent MemberLeave tid now & eventData ?~ EdMemberLeave remove - let r = list1 (userRecipient zusr) (membersToRecipients (Just zusr) (mems ^. teamMembers)) - liftSem . E.push1 $ - newPushLocal1 (mems ^. teamMemberListType) zusr (TeamEvent e) r & pushConn .~ zcon + let r = + list1 + (userRecipient (tUnqualified lusr)) + (membersToRecipients (Just (tUnqualified lusr)) (mems ^. teamMembers)) + E.push1 $ + newPushLocal1 (mems ^. teamMemberListType) (tUnqualified lusr) (TeamEvent e) r & pushConn .~ zcon -- notify all conversation members not in this team. - removeFromConvsAndPushConvLeaveEvent :: UTCTime -> Galley r () + removeFromConvsAndPushConvLeaveEvent :: UTCTime -> Sem r () removeFromConvsAndPushConvLeaveEvent now = do -- This may not make sense if that list has been truncated. In such cases, we still want to -- remove the user from conversations but never send out any events. We assume that clients -- handle nicely these missing events, regardless of whether they are in the same team or not - localDomain <- viewFederationDomain let tmids = Set.fromList $ map (view userId) (mems ^. teamMembers) - let edata = Conv.EdMembersLeave (Conv.QualifiedUserIdList [Qualified remove localDomain]) - cc <- liftSem $ E.getTeamConversations tid + let edata = Conv.EdMembersLeave (Conv.QualifiedUserIdList [qUntagged (qualifyAs lusr remove)]) + cc <- E.getTeamConversations tid for_ cc $ \c -> - liftSem (E.getConversation (c ^. conversationId)) >>= \conv -> + E.getConversation (c ^. conversationId) >>= \conv -> for_ conv $ \dc -> when (remove `isMember` Data.convLocalMembers dc) $ do - liftSem $ E.deleteMembers (c ^. conversationId) (UserList [remove] []) + E.deleteMembers (c ^. conversationId) (UserList [remove] []) -- If the list was truncated, then the tmids list is incomplete so we simply drop these events unless (c ^. managedConversation || mems ^. teamMemberListType == ListTruncated) $ pushEvent tmids edata now dc - pushEvent :: Set UserId -> Conv.EventData -> UTCTime -> Data.Conversation -> Galley r () + pushEvent :: Set UserId -> Conv.EventData -> UTCTime -> Data.Conversation -> Sem r () pushEvent exceptTo edata now dc = do - localDomain <- viewFederationDomain - let qconvId = Qualified (Data.convId dc) localDomain - qusr = Qualified zusr localDomain + let qconvId = qUntagged $ qualifyAs lusr (Data.convId dc) let (bots, users) = localBotsAndUsers (Data.convLocalMembers dc) let x = filter (\m -> not (Conv.lmId m `Set.member` exceptTo)) users - let y = Conv.Event Conv.MemberLeave qconvId qusr now edata - for_ (newPushLocal (mems ^. teamMemberListType) zusr (ConvEvent y) (recipient <$> x)) $ \p -> - liftSem . E.push1 $ p & pushConn .~ zcon - liftSem $ E.deliverAsync (bots `zip` repeat y) + let y = Conv.Event Conv.MemberLeave qconvId (qUntagged lusr) now edata + for_ (newPushLocal (mems ^. teamMemberListType) (tUnqualified lusr) (ConvEvent y) (recipient <$> x)) $ \p -> + E.push1 $ p & pushConn .~ zcon + E.deliverAsync (bots `zip` repeat y) getTeamConversations :: - Members '[Error ActionError, Error TeamError, Error NotATeamMember, TeamStore] r => + Members '[Error ActionError, Error NotATeamMember, TeamStore] r => UserId -> TeamId -> - Galley r Public.TeamConversationList -getTeamConversations zusr tid = liftSem $ do + Sem r Public.TeamConversationList +getTeamConversations zusr tid = do tm <- E.getTeamMember tid zusr >>= noteED @NotATeamMember @@ -1127,7 +1174,6 @@ getTeamConversation :: Members '[ Error ActionError, Error ConversationError, - Error TeamError, Error NotATeamMember, TeamStore ] @@ -1135,8 +1181,8 @@ getTeamConversation :: UserId -> TeamId -> ConvId -> - Galley r Public.TeamConversation -getTeamConversation zusr tid cid = liftSem $ do + Sem r Public.TeamConversation +getTeamConversation zusr tid cid = do tm <- E.getTeamMember tid zusr >>= noteED @NotATeamMember @@ -1147,68 +1193,62 @@ getTeamConversation zusr tid cid = liftSem $ do deleteTeamConversation :: Members - '[ BotAccess, - BrigAccess, - CodeStore, + '[ CodeStore, ConversationStore, Error ActionError, Error ConversationError, Error FederationError, Error InvalidInput, - Error TeamError, Error NotATeamMember, ExternalAccess, FederatorAccess, - FireAndForget, GundeckAccess, - LegalHoldStore, - MemberStore, + Input UTCTime, TeamStore ] r => - UserId -> + Local UserId -> ConnId -> TeamId -> ConvId -> - Galley r () -deleteTeamConversation zusr zcon _tid cid = do - lusr <- qualifyLocal zusr - lconv <- qualifyLocal cid + Sem r () +deleteTeamConversation lusr zcon _tid cid = do + let lconv = qualifyAs lusr cid void $ API.deleteLocalConversation lusr zcon lconv getSearchVisibilityH :: Members '[ Error ActionError, - Error TeamError, Error NotATeamMember, SearchVisibilityStore, TeamStore ] r => UserId ::: TeamId ::: JSON -> - Galley r Response + Sem r Response getSearchVisibilityH (uid ::: tid ::: _) = do - zusrMembership <- liftSem $ E.getTeamMember tid uid + zusrMembership <- E.getTeamMember tid uid void $ permissionCheck ViewTeamSearchVisibility zusrMembership json <$> getSearchVisibilityInternal tid setSearchVisibilityH :: Members '[ Error ActionError, - Error InvalidInput, Error TeamError, Error NotATeamMember, + Input Opts, SearchVisibilityStore, TeamStore, - TeamFeatureStore + TeamFeatureStore, + WaiRoutes ] r => UserId ::: TeamId ::: JsonRequest Public.TeamSearchVisibilityView ::: JSON -> - Galley r Response + Sem r Response setSearchVisibilityH (uid ::: tid ::: req ::: _) = do - zusrMembership <- liftSem $ E.getTeamMember tid uid + zusrMembership <- E.getTeamMember tid uid void $ permissionCheck ChangeTeamSearchVisibility zusrMembership - setSearchVisibilityInternal tid =<< fromJsonBody req + setSearchVisibilityInternal tid =<< (fromJsonBody req) pure noContent -- Internal ----------------------------------------------------------------- @@ -1230,51 +1270,53 @@ withTeamIds :: UserId -> Maybe (Either (Range 1 32 (List TeamId)) TeamId) -> Range 1 100 Int32 -> - (Bool -> [TeamId] -> Galley r a) -> - Galley r a + (Bool -> [TeamId] -> Sem r a) -> + Sem r a withTeamIds usr range size k = case range of Nothing -> do - r <- liftSem $ E.listItems usr Nothing (rcast size) + r <- E.listItems usr Nothing (rcast size) k (resultSetType r == ResultSetTruncated) (resultSetResult r) Just (Right c) -> do - r <- liftSem $ E.listItems usr (Just c) (rcast size) + r <- E.listItems usr (Just c) (rcast size) k (resultSetType r == ResultSetTruncated) (resultSetResult r) Just (Left (fromRange -> cc)) -> do - ids <- liftSem $ E.selectTeams usr (Data.ByteString.Conversion.fromList cc) + ids <- E.selectTeams usr (Data.ByteString.Conversion.fromList cc) k False ids {-# INLINE withTeamIds #-} -ensureUnboundUsers :: Members '[Error TeamError, Error NotATeamMember, TeamStore] r => [UserId] -> Galley r () +ensureUnboundUsers :: Members '[Error TeamError, TeamStore] r => [UserId] -> Sem r () ensureUnboundUsers uids = do -- We check only 1 team because, by definition, users in binding teams -- can only be part of one team. - teams <- liftSem $ Map.elems <$> E.getUsersTeams uids - binds <- liftSem $ E.getTeamsBindings teams - liftSem . when (any (== Binding) binds) $ + teams <- Map.elems <$> E.getUsersTeams uids + binds <- E.getTeamsBindings teams + when (any (== Binding) binds) $ throw UserBindingExists -ensureNonBindingTeam :: Members '[Error TeamError, Error NotATeamMember, TeamStore] r => TeamId -> Galley r () +ensureNonBindingTeam :: Members '[Error TeamError, TeamStore] r => TeamId -> Sem r () ensureNonBindingTeam tid = do - team <- liftSem $ note TeamNotFound =<< E.getTeam tid - liftSem . when ((tdTeam team) ^. teamBinding == Binding) $ + team <- note TeamNotFound =<< E.getTeam tid + when ((tdTeam team) ^. teamBinding == Binding) $ throw NoAddToBinding -- ensure that the permissions are not "greater" than the user's copy permissions -- this is used to ensure users cannot "elevate" permissions -ensureNotElevated :: Member (Error ActionError) r => Permissions -> TeamMember -> Galley r () +ensureNotElevated :: Member (Error ActionError) r => Permissions -> TeamMember -> Sem r () ensureNotElevated targetPermissions member = - liftSem - . unless - ( (targetPermissions ^. self) - `Set.isSubsetOf` (member ^. permissions . copy) - ) + unless + ( (targetPermissions ^. self) + `Set.isSubsetOf` (member ^. permissions . copy) + ) $ throw InvalidPermissions -ensureNotTooLarge :: Members '[BrigAccess, Error TeamError] r => TeamId -> Galley r TeamSize +ensureNotTooLarge :: + Members '[BrigAccess, Error TeamError, Input Opts] r => + TeamId -> + Sem r TeamSize ensureNotTooLarge tid = do - o <- view options - (TeamSize size) <- liftSem $ E.getSize tid - liftSem . unless (size < fromIntegral (o ^. optSettings . setMaxTeamSize)) $ + o <- input + (TeamSize size) <- E.getSize tid + unless (size < fromIntegral (o ^. optSettings . setMaxTeamSize)) $ throw TooManyTeamMembers return $ TeamSize size @@ -1288,29 +1330,35 @@ ensureNotTooLarge tid = do -- LegalHold off after activation. -- FUTUREWORK: Find a way around the fanout limit. ensureNotTooLargeForLegalHold :: - Members '[BrigAccess, Error LegalHoldError, LegalHoldStore, TeamFeatureStore] r => + Members + '[ Error LegalHoldError, + LegalHoldStore, + TeamStore, + TeamFeatureStore + ] + r => TeamId -> Int -> - Galley r () + Sem r () ensureNotTooLargeForLegalHold tid teamSize = whenM (isLegalHoldEnabledForTeam tid) $ unlessM (teamSizeBelowLimit teamSize) $ - liftSem $ throw TooManyTeamMembersOnTeamWithLegalhold + throw TooManyTeamMembersOnTeamWithLegalhold ensureNotTooLargeToActivateLegalHold :: - Members '[BrigAccess, Error TeamError] r => + Members '[BrigAccess, Error TeamError, TeamStore] r => TeamId -> - Galley r () + Sem r () ensureNotTooLargeToActivateLegalHold tid = do - (TeamSize teamSize) <- liftSem $ E.getSize tid + (TeamSize teamSize) <- E.getSize tid unlessM (teamSizeBelowLimit (fromIntegral teamSize)) $ - liftSem $ throw CannotEnableLegalHoldServiceLargeTeam + throw CannotEnableLegalHoldServiceLargeTeam -teamSizeBelowLimit :: Int -> Galley r Bool +teamSizeBelowLimit :: Member TeamStore r => Int -> Sem r Bool teamSizeBelowLimit teamSize = do - limit <- fromIntegral . fromRange <$> fanoutLimit + limit <- fromIntegral . fromRange <$> E.fanoutLimit let withinLimit = teamSize <= limit - view (options . Opts.optSettings . Opts.setFeatureFlags . flagLegalHold) >>= \case + E.getLegalHoldFlag >>= \case FeatureLegalHoldDisabledPermanently -> pure withinLimit FeatureLegalHoldDisabledByDefault -> pure withinLimit FeatureLegalHoldWhitelistTeamsAndImplicitConsent -> @@ -1321,11 +1369,14 @@ addTeamMemberInternal :: Members '[ BrigAccess, Error TeamError, - Error NotATeamMember, GundeckAccess, + Input (Local ()), + Input Opts, + Input UTCTime, MemberStore, TeamNotificationStore, - TeamStore + TeamStore, + P.TinyLog ] r => TeamId -> @@ -1333,21 +1384,21 @@ addTeamMemberInternal :: Maybe ConnId -> NewTeamMember -> TeamMemberList -> - Galley r TeamSize + Sem r TeamSize addTeamMemberInternal tid origin originConn (view ntmNewTeamMember -> new) memList = do - Log.debug $ + P.debug $ Log.field "targets" (toByteString (new ^. userId)) . Log.field "action" (Log.val "Teams.addTeamMemberInternal") sizeBeforeAdd <- ensureNotTooLarge tid - liftSem $ E.createTeamMember tid new - cc <- liftSem $ filter (view managedConversation) <$> E.getTeamConversations tid - now <- liftIO getCurrentTime + E.createTeamMember tid new + cc <- filter (view managedConversation) <$> E.getTeamConversations tid + now <- input for_ cc $ \c -> do lcid <- qualifyLocal (c ^. conversationId) luid <- qualifyLocal (new ^. userId) - liftSem $ E.createMember lcid luid + E.createMember lcid luid let e = newEvent MemberJoin tid now & eventData ?~ EdMemberJoin (new ^. userId) - liftSem . E.push1 $ + E.push1 $ newPushLocal1 (memList ^. teamMemberListType) (new ^. userId) (TeamEvent e) (recipients origin new) & pushConn .~ originConn APITeamQueue.pushTeamEvent tid e return sizeBeforeAdd @@ -1368,7 +1419,6 @@ getTeamNotificationsH :: Members '[ BrigAccess, Error TeamError, - Error NotATeamMember, Error TeamNotificationError, TeamNotificationStore ] @@ -1377,19 +1427,19 @@ getTeamNotificationsH :: ::: Maybe ByteString {- NotificationId -} ::: Range 1 10000 Int32 ::: JSON -> - Galley r Response + Sem r Response getTeamNotificationsH (zusr ::: sinceRaw ::: size ::: _) = do since <- parseSince json @Public.QueuedNotificationList <$> APITeamQueue.getTeamNotifications zusr since size where - parseSince :: Member (Error TeamNotificationError) r => Galley r (Maybe Public.NotificationId) + parseSince :: Member (Error TeamNotificationError) r => Sem r (Maybe Public.NotificationId) parseSince = maybe (pure Nothing) (fmap Just . parseUUID) sinceRaw - parseUUID :: Member (Error TeamNotificationError) r => ByteString -> Galley r Public.NotificationId + parseUUID :: Member (Error TeamNotificationError) r => ByteString -> Sem r Public.NotificationId parseUUID raw = maybe - (liftSem (throw InvalidTeamNotificationId)) + (throw InvalidTeamNotificationId) (pure . Id) ((UUID.fromASCIIBytes >=> isV1UUID) raw) @@ -1397,60 +1447,58 @@ getTeamNotificationsH (zusr ::: sinceRaw ::: size ::: _) = do isV1UUID u = if UUID.version u == 1 then Just u else Nothing finishCreateTeam :: - Members '[GundeckAccess, TeamStore] r => + Members '[GundeckAccess, Input UTCTime, TeamStore] r => Team -> TeamMember -> [TeamMember] -> Maybe ConnId -> - Galley r () + Sem r () finishCreateTeam team owner others zcon = do let zusr = owner ^. userId - liftSem $ - for_ (owner : others) $ - E.createTeamMember (team ^. teamId) - now <- liftIO getCurrentTime + for_ (owner : others) $ + E.createTeamMember (team ^. teamId) + now <- input let e = newEvent TeamCreate (team ^. teamId) now & eventData ?~ EdTeamCreate team let r = membersToRecipients Nothing others - liftSem . E.push1 $ newPushLocal1 ListComplete zusr (TeamEvent e) (list1 (userRecipient zusr) r) & pushConn .~ zcon + E.push1 $ newPushLocal1 ListComplete zusr (TeamEvent e) (list1 (userRecipient zusr) r) & pushConn .~ zcon -- FUTUREWORK: Get rid of CPS withBindingTeam :: - Members '[Error TeamError, Error NotATeamMember, TeamStore] r => + Members '[Error TeamError, TeamStore] r => UserId -> - (TeamId -> Galley r b) -> - Galley r b + (TeamId -> Sem r b) -> + Sem r b withBindingTeam zusr callback = do - tid <- liftSem $ E.getOneUserTeam zusr >>= note TeamNotFound - binding <- liftSem $ E.getTeamBinding tid >>= note TeamNotFound + tid <- E.getOneUserTeam zusr >>= note TeamNotFound + binding <- E.getTeamBinding tid >>= note TeamNotFound case binding of Binding -> callback tid - NonBinding -> liftSem $ throw NotABindingTeamMember + NonBinding -> throw NotABindingTeamMember -getBindingTeamIdH :: Members '[Error TeamError, Error NotATeamMember, TeamStore] r => UserId -> Galley r Response +getBindingTeamIdH :: Members '[Error TeamError, TeamStore] r => UserId -> Sem r Response getBindingTeamIdH = fmap json . getBindingTeamId -getBindingTeamId :: Members '[Error TeamError, Error NotATeamMember, TeamStore] r => UserId -> Galley r TeamId +getBindingTeamId :: Members '[Error TeamError, TeamStore] r => UserId -> Sem r TeamId getBindingTeamId zusr = withBindingTeam zusr pure -getBindingTeamMembersH :: Members '[Error TeamError, Error NotATeamMember, TeamStore] r => UserId -> Galley r Response +getBindingTeamMembersH :: Members '[Error TeamError, TeamStore] r => UserId -> Sem r Response getBindingTeamMembersH = fmap json . getBindingTeamMembers getBindingTeamMembers :: Members '[ Error TeamError, - Error NotATeamMember, TeamStore ] r => UserId -> - Galley r TeamMemberList + Sem r TeamMemberList getBindingTeamMembers zusr = withBindingTeam zusr $ \tid -> getTeamMembersForFanout tid canUserJoinTeamH :: - Members '[BrigAccess, Error LegalHoldError, LegalHoldStore, TeamFeatureStore] r => + Members '[BrigAccess, Error LegalHoldError, LegalHoldStore, TeamStore, TeamFeatureStore] r => TeamId -> - Galley r Response + Sem r Response canUserJoinTeamH tid = canUserJoinTeam tid >> pure empty -- This could be extended for more checks, for now we test only legalhold @@ -1459,102 +1507,106 @@ canUserJoinTeam :: '[ BrigAccess, Error LegalHoldError, LegalHoldStore, + TeamStore, TeamFeatureStore ] r => TeamId -> - Galley r () + Sem r () canUserJoinTeam tid = do lhEnabled <- isLegalHoldEnabledForTeam tid when lhEnabled $ do - (TeamSize sizeBeforeJoin) <- liftSem $ E.getSize tid + (TeamSize sizeBeforeJoin) <- E.getSize tid ensureNotTooLargeForLegalHold tid (fromIntegral sizeBeforeJoin + 1) getTeamSearchVisibilityAvailableInternal :: - Member TeamFeatureStore r => + Members '[Input Opts, TeamFeatureStore] r => TeamId -> - Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureSearchVisibility) + Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureSearchVisibility) getTeamSearchVisibilityAvailableInternal tid = do -- TODO: This is just redundant given there is a decent default defConfig <- do - featureTeamSearchVisibility <- view (options . optSettings . setFeatureFlags . flagTeamSearchVisibility) + featureTeamSearchVisibility <- view (optSettings . setFeatureFlags . flagTeamSearchVisibility) <$> input pure . Public.TeamFeatureStatusNoConfig $ case featureTeamSearchVisibility of FeatureTeamSearchVisibilityEnabledByDefault -> Public.TeamFeatureEnabled FeatureTeamSearchVisibilityDisabledByDefault -> Public.TeamFeatureDisabled - liftSem $ - fromMaybe defConfig - <$> TeamFeatures.getFeatureStatusNoConfig @'Public.TeamFeatureSearchVisibility tid + fromMaybe defConfig + <$> TeamFeatures.getFeatureStatusNoConfig @'Public.TeamFeatureSearchVisibility tid -- | Modify and get visibility type for a team (internal, no user permission checks) getSearchVisibilityInternalH :: Member SearchVisibilityStore r => TeamId ::: JSON -> - Galley r Response + Sem r Response getSearchVisibilityInternalH (tid ::: _) = json <$> getSearchVisibilityInternal tid getSearchVisibilityInternal :: Member SearchVisibilityStore r => TeamId -> - Galley r TeamSearchVisibilityView + Sem r TeamSearchVisibilityView getSearchVisibilityInternal = - fmap TeamSearchVisibilityView . liftSem + fmap TeamSearchVisibilityView . SearchVisibilityData.getSearchVisibility setSearchVisibilityInternalH :: Members - '[ Error InvalidInput, - Error TeamError, - Error NotATeamMember, + '[ Error TeamError, + Input Opts, SearchVisibilityStore, - TeamFeatureStore + TeamFeatureStore, + WaiRoutes ] r => TeamId ::: JsonRequest TeamSearchVisibilityView ::: JSON -> - Galley r Response + Sem r Response setSearchVisibilityInternalH (tid ::: req ::: _) = do - setSearchVisibilityInternal tid =<< fromJsonBody req + setSearchVisibilityInternal tid =<< (fromJsonBody req) pure noContent setSearchVisibilityInternal :: - Members '[Error TeamError, Error NotATeamMember, SearchVisibilityStore, TeamFeatureStore] r => + Members + '[ Error TeamError, + Input Opts, + SearchVisibilityStore, + TeamFeatureStore + ] + r => TeamId -> TeamSearchVisibilityView -> - Galley r () + Sem r () setSearchVisibilityInternal tid (TeamSearchVisibilityView searchVisibility) = do status <- getTeamSearchVisibilityAvailableInternal tid - liftSem . unless (Public.tfwoStatus status == Public.TeamFeatureEnabled) $ + unless (Public.tfwoStatus status == Public.TeamFeatureEnabled) $ throw TeamSearchVisibilityNotEnabled - liftSem $ SearchVisibilityData.setSearchVisibility tid searchVisibility + SearchVisibilityData.setSearchVisibility tid searchVisibility userIsTeamOwnerH :: Members '[Error ActionError, Error TeamError, Error NotATeamMember, TeamStore] r => TeamId ::: UserId ::: JSON -> - Galley r Response + Sem r Response userIsTeamOwnerH (tid ::: uid ::: _) = do userIsTeamOwner tid uid >>= \case True -> pure empty - False -> liftSem $ throw AccessDenied + False -> throw AccessDenied userIsTeamOwner :: Members '[Error TeamError, Error NotATeamMember, TeamStore] r => TeamId -> UserId -> - Galley r Bool + Sem r Bool userIsTeamOwner tid uid = do let asking = uid isTeamOwner . fst <$> getTeamMember asking tid uid -- Queues a team for async deletion queueTeamDeletion :: - Member (Error InternalError) r => + Members '[Error InternalError, Queue DeleteItem] r => TeamId -> UserId -> Maybe ConnId -> - Galley r () + Sem r () queueTeamDeletion tid zusr zcon = do - q <- view deleteQueue - ok <- Q.tryPush q (TeamItem tid zusr zcon) - liftSem . unless ok $ - throw DeleteQueueFull + ok <- E.tryPush (TeamItem tid zusr zcon) + unless ok $ throw DeleteQueueFull diff --git a/services/galley/src/Galley/API/Teams/Features.hs b/services/galley/src/Galley/API/Teams/Features.hs index 4498865cf33..19e49f76b1b 100644 --- a/services/galley/src/Galley/API/Teams/Features.hs +++ b/services/galley/src/Galley/API/Teams/Features.hs @@ -50,16 +50,17 @@ import qualified Data.Aeson as Aeson import Data.ByteString.Conversion hiding (fromList) import qualified Data.HashMap.Strict as HashMap import Data.Id -import Data.Proxy (Proxy (Proxy)) +import Data.Qualified import Data.String.Conversions (cs) +import Data.Time.Clock import Galley.API.Error as Galley import Galley.API.LegalHold import Galley.API.Teams (ensureNotTooLargeToActivateLegalHold) import Galley.API.Util -import Galley.App import Galley.Cassandra.Paging import Galley.Data.TeamFeatures import Galley.Effects +import Galley.Effects.BrigAccess import Galley.Effects.GundeckAccess import Galley.Effects.Paging import qualified Galley.Effects.SearchVisibilityStore as SearchVisibilityData @@ -69,20 +70,18 @@ import Galley.Intra.Push (PushEvent (FeatureConfigEvent), newPush) import Galley.Options import Galley.Types.Teams hiding (newTeam) import Imports -import Network.HTTP.Client (Manager) import Network.Wai import Network.Wai.Predicate hiding (Error, or, result, setStatus) import Network.Wai.Utilities hiding (Error) +import Polysemy import Polysemy.Error -import Servant.API ((:<|>) ((:<|>))) -import qualified Servant.Client as Client +import Polysemy.Input +import qualified Polysemy.TinyLog as P import qualified System.Logger.Class as Log -import Util.Options (Endpoint, epHost, epPort) import Wire.API.ErrorDescription import Wire.API.Event.FeatureConfig import qualified Wire.API.Event.FeatureConfig as Event import Wire.API.Federation.Client -import qualified Wire.API.Routes.Internal.Brig as IAPI import Wire.API.Team.Feature (AllFeatureConfigs (..), FeatureHasNoConfig, KnownTeamFeatureName, TeamFeatureName) import qualified Wire.API.Team.Feature as Public @@ -101,14 +100,14 @@ getFeatureStatus :: ] r ) => - (GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus a)) -> + (GetFeatureInternalParam -> Sem r (Public.TeamFeatureStatus a)) -> DoAuth -> TeamId -> - Galley r (Public.TeamFeatureStatus a) + Sem r (Public.TeamFeatureStatus a) getFeatureStatus getter doauth tid = do case doauth of DoAuth uid -> do - zusrMembership <- liftSem $ getTeamMember tid uid + zusrMembership <- getTeamMember tid uid void $ permissionCheck (ViewTeamFeature (Public.knownTeamFeatureName @a)) zusrMembership DontDoAuth -> assertTeamExists tid @@ -126,15 +125,15 @@ setFeatureStatus :: ] r ) => - (TeamId -> Public.TeamFeatureStatus a -> Galley r (Public.TeamFeatureStatus a)) -> + (TeamId -> Public.TeamFeatureStatus a -> Sem r (Public.TeamFeatureStatus a)) -> DoAuth -> TeamId -> Public.TeamFeatureStatus a -> - Galley r (Public.TeamFeatureStatus a) + Sem r (Public.TeamFeatureStatus a) setFeatureStatus setter doauth tid status = do case doauth of DoAuth uid -> do - zusrMembership <- liftSem $ getTeamMember tid uid + zusrMembership <- getTeamMember tid uid void $ permissionCheck (ChangeTeamFeature (Public.knownTeamFeatureName @a)) zusrMembership DontDoAuth -> assertTeamExists tid @@ -152,43 +151,44 @@ getFeatureConfig :: ] r ) => - (GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus a)) -> + (GetFeatureInternalParam -> Sem r (Public.TeamFeatureStatus a)) -> UserId -> - Galley r (Public.TeamFeatureStatus a) + Sem r (Public.TeamFeatureStatus a) getFeatureConfig getter zusr = do - mbTeam <- liftSem $ getOneUserTeam zusr + mbTeam <- getOneUserTeam zusr case mbTeam of Nothing -> getter (Left (Just zusr)) Just tid -> do - zusrMembership <- liftSem $ getTeamMember tid zusr + zusrMembership <- getTeamMember tid zusr void $ permissionCheck (ViewTeamFeature (Public.knownTeamFeatureName @a)) zusrMembership assertTeamExists tid getter (Right tid) getAllFeatureConfigs :: Members - '[ Error ActionError, - Error InternalError, + '[ BrigAccess, + Error ActionError, Error NotATeamMember, Error TeamError, + Input Opts, LegalHoldStore, TeamFeatureStore, TeamStore ] r => UserId -> - Galley r AllFeatureConfigs + Sem r AllFeatureConfigs getAllFeatureConfigs zusr = do - mbTeam <- liftSem $ getOneUserTeam zusr - zusrMembership <- maybe (pure Nothing) (liftSem . (flip getTeamMember zusr)) mbTeam + mbTeam <- getOneUserTeam zusr + zusrMembership <- maybe (pure Nothing) ((flip getTeamMember zusr)) mbTeam let getStatus :: forall (a :: Public.TeamFeatureName) r. ( Public.KnownTeamFeatureName a, Aeson.ToJSON (Public.TeamFeatureStatus a), Members '[Error ActionError, Error TeamError, Error NotATeamMember, TeamStore] r ) => - (GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus a)) -> - Galley r (Text, Aeson.Value) + (GetFeatureInternalParam -> Sem r (Public.TeamFeatureStatus a)) -> + Sem r (Text, Aeson.Value) getStatus getter = do when (isJust mbTeam) $ do void $ permissionCheck (ViewTeamFeature (Public.knownTeamFeatureName @a)) zusrMembership @@ -212,27 +212,29 @@ getAllFeatureConfigs zusr = do getAllFeaturesH :: Members - '[ Error ActionError, - Error InternalError, + '[ BrigAccess, + Error ActionError, Error TeamError, Error NotATeamMember, + Input Opts, LegalHoldStore, TeamFeatureStore, TeamStore ] r => UserId ::: TeamId ::: JSON -> - Galley r Response + Sem r Response getAllFeaturesH (uid ::: tid ::: _) = json <$> getAllFeatures uid tid getAllFeatures :: forall r. Members - '[ Error ActionError, - Error InternalError, + '[ BrigAccess, + Error ActionError, Error TeamError, Error NotATeamMember, + Input Opts, LegalHoldStore, TeamFeatureStore, TeamStore @@ -240,7 +242,7 @@ getAllFeatures :: r => UserId -> TeamId -> - Galley r Aeson.Value + Sem r Aeson.Value getAllFeatures uid tid = do Aeson.object <$> sequence @@ -261,8 +263,8 @@ getAllFeatures uid tid = do ( Public.KnownTeamFeatureName a, Aeson.ToJSON (Public.TeamFeatureStatus a) ) => - (GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus a)) -> - Galley r (Text, Aeson.Value) + (GetFeatureInternalParam -> Sem r (Public.TeamFeatureStatus a)) -> + Sem r (Text, Aeson.Value) getStatus getter = do status <- getFeatureStatus @a getter (DoAuth uid) tid let feature = Public.knownTeamFeatureName @a @@ -274,27 +276,27 @@ getFeatureStatusNoConfig :: HasStatusCol a, Member TeamFeatureStore r ) => - Galley r Public.TeamFeatureStatusValue -> + Sem r Public.TeamFeatureStatusValue -> TeamId -> - Galley r (Public.TeamFeatureStatus a) + Sem r (Public.TeamFeatureStatus a) getFeatureStatusNoConfig getDefault tid = do defaultStatus <- Public.TeamFeatureStatusNoConfig <$> getDefault - liftSem $ fromMaybe defaultStatus <$> TeamFeatures.getFeatureStatusNoConfig @a tid + fromMaybe defaultStatus <$> TeamFeatures.getFeatureStatusNoConfig @a tid setFeatureStatusNoConfig :: forall (a :: Public.TeamFeatureName) r. ( Public.KnownTeamFeatureName a, Public.FeatureHasNoConfig a, HasStatusCol a, - Members '[GundeckAccess, TeamFeatureStore, TeamStore] r + Members '[GundeckAccess, TeamFeatureStore, TeamStore, P.TinyLog] r ) => - (Public.TeamFeatureStatusValue -> TeamId -> Galley r ()) -> + (Public.TeamFeatureStatusValue -> TeamId -> Sem r ()) -> TeamId -> Public.TeamFeatureStatus a -> - Galley r (Public.TeamFeatureStatus a) + Sem r (Public.TeamFeatureStatus a) setFeatureStatusNoConfig applyState tid status = do applyState (Public.tfwoStatus status) tid - newStatus <- liftSem $ TeamFeatures.setFeatureStatusNoConfig @a tid status + newStatus <- TeamFeatures.setFeatureStatusNoConfig @a tid status pushFeatureConfigEvent tid $ Event.Event Event.Update (Public.knownTeamFeatureName @a) (EdFeatureWithoutConfigChanged newStatus) pure newStatus @@ -304,56 +306,56 @@ setFeatureStatusNoConfig applyState tid status = do type GetFeatureInternalParam = Either (Maybe UserId) TeamId getSSOStatusInternal :: - Member TeamFeatureStore r => + Members '[Input Opts, TeamFeatureStore] r => GetFeatureInternalParam -> - Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureSSO) + Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureSSO) getSSOStatusInternal = either (const $ Public.TeamFeatureStatusNoConfig <$> getDef) (getFeatureStatusNoConfig @'Public.TeamFeatureSSO getDef) where - getDef :: Galley r Public.TeamFeatureStatusValue + getDef :: Member (Input Opts) r => Sem r Public.TeamFeatureStatusValue getDef = - view (options . optSettings . setFeatureFlags . flagSSO) <&> \case + inputs (view (optSettings . setFeatureFlags . flagSSO)) <&> \case FeatureSSOEnabledByDefault -> Public.TeamFeatureEnabled FeatureSSODisabledByDefault -> Public.TeamFeatureDisabled setSSOStatusInternal :: - Members '[Error TeamFeatureError, GundeckAccess, TeamFeatureStore, TeamStore] r => + Members '[Error TeamFeatureError, GundeckAccess, TeamFeatureStore, TeamStore, P.TinyLog] r => TeamId -> (Public.TeamFeatureStatus 'Public.TeamFeatureSSO) -> - Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureSSO) + Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureSSO) setSSOStatusInternal = setFeatureStatusNoConfig @'Public.TeamFeatureSSO $ \case - Public.TeamFeatureDisabled -> const (liftSem (throw DisableSsoNotImplemented)) + Public.TeamFeatureDisabled -> const (throw DisableSsoNotImplemented) Public.TeamFeatureEnabled -> const (pure ()) getTeamSearchVisibilityAvailableInternal :: - Member TeamFeatureStore r => + Members '[Input Opts, TeamFeatureStore] r => GetFeatureInternalParam -> - Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureSearchVisibility) + Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureSearchVisibility) getTeamSearchVisibilityAvailableInternal = either (const $ Public.TeamFeatureStatusNoConfig <$> getDef) (getFeatureStatusNoConfig @'Public.TeamFeatureSearchVisibility getDef) where getDef = do - view (options . optSettings . setFeatureFlags . flagTeamSearchVisibility) <&> \case + inputs (view (optSettings . setFeatureFlags . flagTeamSearchVisibility)) <&> \case FeatureTeamSearchVisibilityEnabledByDefault -> Public.TeamFeatureEnabled FeatureTeamSearchVisibilityDisabledByDefault -> Public.TeamFeatureDisabled setTeamSearchVisibilityAvailableInternal :: - Members '[GundeckAccess, SearchVisibilityStore, TeamFeatureStore, TeamStore] r => + Members '[GundeckAccess, SearchVisibilityStore, TeamFeatureStore, TeamStore, P.TinyLog] r => TeamId -> (Public.TeamFeatureStatus 'Public.TeamFeatureSearchVisibility) -> - Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureSearchVisibility) + Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureSearchVisibility) setTeamSearchVisibilityAvailableInternal = setFeatureStatusNoConfig @'Public.TeamFeatureSearchVisibility $ \case - Public.TeamFeatureDisabled -> liftSem . SearchVisibilityData.resetSearchVisibility + Public.TeamFeatureDisabled -> SearchVisibilityData.resetSearchVisibility Public.TeamFeatureEnabled -> const (pure ()) getValidateSAMLEmailsInternal :: Member TeamFeatureStore r => GetFeatureInternalParam -> - Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureValidateSAMLEmails) + Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureValidateSAMLEmails) getValidateSAMLEmailsInternal = either (const $ Public.TeamFeatureStatusNoConfig <$> getDef) @@ -365,16 +367,16 @@ getValidateSAMLEmailsInternal = getDef = pure Public.TeamFeatureDisabled setValidateSAMLEmailsInternal :: - Members '[GundeckAccess, TeamFeatureStore, TeamStore] r => + Members '[GundeckAccess, TeamFeatureStore, TeamStore, P.TinyLog] r => TeamId -> (Public.TeamFeatureStatus 'Public.TeamFeatureValidateSAMLEmails) -> - Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureValidateSAMLEmails) + Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureValidateSAMLEmails) setValidateSAMLEmailsInternal = setFeatureStatusNoConfig @'Public.TeamFeatureValidateSAMLEmails $ \_ _ -> pure () getDigitalSignaturesInternal :: Member TeamFeatureStore r => GetFeatureInternalParam -> - Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureDigitalSignatures) + Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureDigitalSignatures) getDigitalSignaturesInternal = either (const $ Public.TeamFeatureStatusNoConfig <$> getDef) @@ -386,16 +388,16 @@ getDigitalSignaturesInternal = getDef = pure Public.TeamFeatureDisabled setDigitalSignaturesInternal :: - Members '[GundeckAccess, TeamFeatureStore, TeamStore] r => + Members '[GundeckAccess, TeamFeatureStore, TeamStore, P.TinyLog] r => TeamId -> Public.TeamFeatureStatus 'Public.TeamFeatureDigitalSignatures -> - Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureDigitalSignatures) + Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureDigitalSignatures) setDigitalSignaturesInternal = setFeatureStatusNoConfig @'Public.TeamFeatureDigitalSignatures $ \_ _ -> pure () getLegalholdStatusInternal :: - Members '[LegalHoldStore, TeamFeatureStore] r => + Members '[LegalHoldStore, TeamFeatureStore, TeamStore] r => GetFeatureInternalParam -> - Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureLegalHold) + Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureLegalHold) getLegalholdStatusInternal (Left _) = pure $ Public.TeamFeatureStatusNoConfig Public.TeamFeatureDisabled getLegalholdStatusInternal (Right tid) = do @@ -404,6 +406,7 @@ getLegalholdStatusInternal (Right tid) = do False -> Public.TeamFeatureStatusNoConfig Public.TeamFeatureDisabled setLegalholdStatusInternal :: + forall p r. ( Paging p, Bounded (PagingBounds p TeamMember), Members @@ -424,25 +427,28 @@ setLegalholdStatusInternal :: FederatorAccess, FireAndForget, GundeckAccess, + Input (Local ()), + Input UTCTime, LegalHoldStore, ListItems LegacyPaging ConvId, MemberStore, TeamFeatureStore, TeamStore, - TeamMemberStore p + TeamMemberStore p, + P.TinyLog ] r ) => TeamId -> Public.TeamFeatureStatus 'Public.TeamFeatureLegalHold -> - Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureLegalHold) + Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureLegalHold) setLegalholdStatusInternal tid status@(Public.tfwoStatus -> statusValue) = do do -- this extra do is to encapsulate the assertions running before the actual operation. -- enabeling LH for teams is only allowed in normal operation; disabled-permanently and -- whitelist-teams have no or their own way to do that, resp. - featureLegalHold <- view (options . optSettings . setFeatureFlags . flagLegalHold) - liftSem $ case featureLegalHold of + featureLegalHold <- getLegalHoldFlag + case featureLegalHold of FeatureLegalHoldDisabledByDefault -> do pure () FeatureLegalHoldDisabledPermanently -> do @@ -452,68 +458,74 @@ setLegalholdStatusInternal tid status@(Public.tfwoStatus -> statusValue) = do -- we're good to update the status now. case statusValue of - Public.TeamFeatureDisabled -> removeSettings' tid + Public.TeamFeatureDisabled -> removeSettings' @p tid Public.TeamFeatureEnabled -> do ensureNotTooLargeToActivateLegalHold tid - liftSem $ TeamFeatures.setFeatureStatusNoConfig @'Public.TeamFeatureLegalHold tid status + TeamFeatures.setFeatureStatusNoConfig @'Public.TeamFeatureLegalHold tid status getFileSharingInternal :: - Member TeamFeatureStore r => + Members '[Input Opts, TeamFeatureStore] r => GetFeatureInternalParam -> - Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureFileSharing) + Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureFileSharing) getFileSharingInternal = getFeatureStatusWithDefaultConfig @'Public.TeamFeatureFileSharing flagFileSharing . either (const Nothing) Just getFeatureStatusWithDefaultConfig :: forall (a :: TeamFeatureName) r. - (KnownTeamFeatureName a, HasStatusCol a, FeatureHasNoConfig a, Member TeamFeatureStore r) => + ( KnownTeamFeatureName a, + HasStatusCol a, + FeatureHasNoConfig a, + Members '[Input Opts, TeamFeatureStore] r + ) => Lens' FeatureFlags (Defaults (Public.TeamFeatureStatus a)) -> Maybe TeamId -> - Galley r (Public.TeamFeatureStatus a) + Sem r (Public.TeamFeatureStatus a) getFeatureStatusWithDefaultConfig lens' = maybe (Public.TeamFeatureStatusNoConfig <$> getDef) (getFeatureStatusNoConfig @a getDef) where - getDef :: Galley r Public.TeamFeatureStatusValue + getDef :: Sem r Public.TeamFeatureStatusValue getDef = - view (options . optSettings . setFeatureFlags . lens') + inputs (view (optSettings . setFeatureFlags . lens')) <&> Public.tfwoStatus . view unDefaults setFileSharingInternal :: - Members '[GundeckAccess, TeamFeatureStore, TeamStore] r => + Members '[GundeckAccess, TeamFeatureStore, TeamStore, P.TinyLog] r => TeamId -> Public.TeamFeatureStatus 'Public.TeamFeatureFileSharing -> - Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureFileSharing) + Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureFileSharing) setFileSharingInternal = setFeatureStatusNoConfig @'Public.TeamFeatureFileSharing $ \_status _tid -> pure () getAppLockInternal :: - Member TeamFeatureStore r => + Members '[Input Opts, TeamFeatureStore] r => GetFeatureInternalParam -> - Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureAppLock) + Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureAppLock) getAppLockInternal mbtid = do - Defaults defaultStatus <- view (options . optSettings . setFeatureFlags . flagAppLockDefaults) + Defaults defaultStatus <- inputs (view (optSettings . setFeatureFlags . flagAppLockDefaults)) status <- - liftSem $ - join <$> (TeamFeatures.getApplockFeatureStatus `mapM` either (const Nothing) Just mbtid) + join <$> (TeamFeatures.getApplockFeatureStatus `mapM` either (const Nothing) Just mbtid) pure $ fromMaybe defaultStatus status setAppLockInternal :: - Members '[GundeckAccess, TeamFeatureStore, TeamStore, Error TeamFeatureError] r => + Members '[GundeckAccess, TeamFeatureStore, TeamStore, Error TeamFeatureError, P.TinyLog] r => TeamId -> Public.TeamFeatureStatus 'Public.TeamFeatureAppLock -> - Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureAppLock) + Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureAppLock) setAppLockInternal tid status = do when (Public.applockInactivityTimeoutSecs (Public.tfwcConfig status) < 30) $ - liftSem $ throw AppLockinactivityTimeoutTooLow + throw AppLockinactivityTimeoutTooLow let pushEvent = pushFeatureConfigEvent tid $ Event.Event Event.Update Public.TeamFeatureAppLock (EdFeatureApplockChanged status) - (liftSem $ TeamFeatures.setApplockFeatureStatus tid status) <* pushEvent + (TeamFeatures.setApplockFeatureStatus tid status) <* pushEvent -getClassifiedDomainsInternal :: GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureClassifiedDomains) +getClassifiedDomainsInternal :: + Member (Input Opts) r => + GetFeatureInternalParam -> + Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureClassifiedDomains) getClassifiedDomainsInternal _mbtid = do - globalConfig <- view (options . optSettings . setFeatureFlags . flagClassifiedDomains) + globalConfig <- inputs (view (optSettings . setFeatureFlags . flagClassifiedDomains)) let config = globalConfig pure $ case Public.tfwcStatus config of Public.TeamFeatureDisabled -> @@ -521,9 +533,9 @@ getClassifiedDomainsInternal _mbtid = do Public.TeamFeatureEnabled -> config getConferenceCallingInternal :: - Members '[Error InternalError, TeamFeatureStore] r => + Members '[BrigAccess, Input Opts, TeamFeatureStore] r => GetFeatureInternalParam -> - Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureConferenceCalling) + Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureConferenceCalling) getConferenceCallingInternal (Left (Just uid)) = do getFeatureConfigViaAccount @'Public.TeamFeatureConferenceCalling uid getConferenceCallingInternal (Left Nothing) = do @@ -532,44 +544,43 @@ getConferenceCallingInternal (Right tid) = do getFeatureStatusWithDefaultConfig @'Public.TeamFeatureConferenceCalling flagConferenceCalling (Just tid) setConferenceCallingInternal :: - Members '[GundeckAccess, TeamFeatureStore, TeamStore] r => + Members '[GundeckAccess, TeamFeatureStore, TeamStore, P.TinyLog] r => TeamId -> Public.TeamFeatureStatus 'Public.TeamFeatureConferenceCalling -> - Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureConferenceCalling) + Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureConferenceCalling) setConferenceCallingInternal = setFeatureStatusNoConfig @'Public.TeamFeatureConferenceCalling $ \_status _tid -> pure () getSelfDeletingMessagesInternal :: Member TeamFeatureStore r => GetFeatureInternalParam -> - Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureSelfDeletingMessages) + Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureSelfDeletingMessages) getSelfDeletingMessagesInternal = \case Left _ -> pure Public.defaultSelfDeletingMessagesStatus Right tid -> - liftSem $ - TeamFeatures.getSelfDeletingMessagesStatus tid - <&> maybe Public.defaultSelfDeletingMessagesStatus id + TeamFeatures.getSelfDeletingMessagesStatus tid + <&> maybe Public.defaultSelfDeletingMessagesStatus id setSelfDeletingMessagesInternal :: - Members '[GundeckAccess, TeamFeatureStore, TeamStore] r => + Members '[GundeckAccess, TeamFeatureStore, TeamStore, P.TinyLog] r => TeamId -> Public.TeamFeatureStatus 'Public.TeamFeatureSelfDeletingMessages -> - Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureSelfDeletingMessages) + Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureSelfDeletingMessages) setSelfDeletingMessagesInternal tid st = do let pushEvent = pushFeatureConfigEvent tid $ Event.Event Event.Update Public.TeamFeatureSelfDeletingMessages (EdFeatureSelfDeletingMessagesChanged st) - (liftSem $ TeamFeatures.setSelfDeletingMessagesStatus tid st) <* pushEvent + (TeamFeatures.setSelfDeletingMessagesStatus tid st) <* pushEvent pushFeatureConfigEvent :: - Members '[GundeckAccess, TeamStore] r => + Members '[GundeckAccess, TeamStore, P.TinyLog] r => TeamId -> Event.Event -> - Galley r () + Sem r () pushFeatureConfigEvent tid event = do memList <- getTeamMembersForFanout tid when ((memList ^. teamMemberListType) == ListTruncated) $ do - Log.warn $ + P.warn $ Log.field "action" (Log.val "Features.pushFeatureConfigEvent") . Log.field "feature" (Log.val (toByteString' . Event._eventFeatureName $ event)) . Log.field "team" (Log.val (cs . show $ tid)) @@ -577,49 +588,14 @@ pushFeatureConfigEvent tid event = do let recipients = membersToRecipients Nothing (memList ^. teamMembers) for_ (newPush (memList ^. teamMemberListType) Nothing (FeatureConfigEvent event) recipients) - (liftSem . push1) + (push1) -- | (Currently, we only have 'Public.TeamFeatureConferenceCalling' here, but we may have to -- extend this in the future.) getFeatureConfigViaAccount :: - (flag ~ 'Public.TeamFeatureConferenceCalling, Member (Error InternalError) r) => + ( flag ~ 'Public.TeamFeatureConferenceCalling, + Member BrigAccess r + ) => UserId -> - Galley r (Public.TeamFeatureStatus flag) -getFeatureConfigViaAccount uid = do - mgr <- asks (^. manager) - brigep <- asks (^. brig) - getAccountFeatureConfigClient brigep mgr uid >>= handleResp - where - handleResp :: - Member (Error InternalError) r => - Either Client.ClientError Public.TeamFeatureStatusNoConfig -> - Galley r Public.TeamFeatureStatusNoConfig - handleResp (Right cfg) = pure cfg - handleResp (Left errmsg) = liftSem . throw . InternalErrorWithDescription . cs . show $ errmsg - - getAccountFeatureConfigClient :: - (HasCallStack, MonadIO m) => - Endpoint -> - Manager -> - UserId -> - m (Either Client.ClientError Public.TeamFeatureStatusNoConfig) - getAccountFeatureConfigClient brigep mgr = runHereClientM brigep mgr . getAccountFeatureConfigClientM - - getAccountFeatureConfigClientM :: - UserId -> Client.ClientM Public.TeamFeatureStatusNoConfig - ( _ - :<|> getAccountFeatureConfigClientM - :<|> _ - :<|> _ - ) = Client.client (Proxy @IAPI.API) - - runHereClientM :: - (HasCallStack, MonadIO m) => - Endpoint -> - Manager -> - Client.ClientM a -> - m (Either Client.ClientError a) - runHereClientM brigep mgr action = do - let env = Client.mkClientEnv mgr baseurl - baseurl = Client.BaseUrl Client.Http (cs $ brigep ^. epHost) (fromIntegral $ brigep ^. epPort) "" - liftIO $ Client.runClientM action env + Sem r (Public.TeamFeatureStatus flag) +getFeatureConfigViaAccount = getAccountFeatureConfigClient diff --git a/services/galley/src/Galley/API/Teams/Notifications.hs b/services/galley/src/Galley/API/Teams/Notifications.hs index 0836369ee8a..c84918ccd53 100644 --- a/services/galley/src/Galley/API/Teams/Notifications.hs +++ b/services/galley/src/Galley/API/Teams/Notifications.hs @@ -41,15 +41,11 @@ where import Brig.Types.Intra (accountUser) import Brig.Types.User (userTeam) -import Control.Monad.Catch -import Control.Retry (exponentialBackoff, limitRetries, retrying) import Data.Id import Data.Json.Util (toJSONObject) import qualified Data.List1 as List1 import Data.Range (Range) -import qualified Data.UUID.V1 as UUID import Galley.API.Error -import Galley.App import qualified Galley.Data.TeamNotifications as DataTeamQueue import Galley.Effects import Galley.Effects.BrigAccess as Intra @@ -57,8 +53,7 @@ import qualified Galley.Effects.TeamNotificationStore as E import Galley.Types.Teams hiding (newTeam) import Gundeck.Types.Notification import Imports -import Network.HTTP.Types -import Network.Wai.Utilities hiding (Error) +import Polysemy import Polysemy.Error getTeamNotifications :: @@ -66,27 +61,17 @@ getTeamNotifications :: UserId -> Maybe NotificationId -> Range 1 10000 Int32 -> - Galley r QueuedNotificationList + Sem r QueuedNotificationList getTeamNotifications zusr since size = do - tid <- liftSem . (note TeamNotFound =<<) $ (userTeam . accountUser =<<) <$> Intra.getUser zusr - page <- liftSem $ E.getTeamNotifications tid since size + tid <- (note TeamNotFound =<<) $ (userTeam . accountUser =<<) <$> Intra.getUser zusr + page <- E.getTeamNotifications tid since size pure $ queuedNotificationList (toList (DataTeamQueue.resultSeq page)) (DataTeamQueue.resultHasMore page) Nothing -pushTeamEvent :: Member TeamNotificationStore r => TeamId -> Event -> Galley r () +pushTeamEvent :: Member TeamNotificationStore r => TeamId -> Event -> Sem r () pushTeamEvent tid evt = do - nid <- liftIO mkNotificationId - liftSem $ E.createTeamNotification tid nid (List1.singleton $ toJSONObject evt) - --- | 'Data.UUID.V1.nextUUID' is sometimes unsuccessful, so we try a few times. -mkNotificationId :: IO NotificationId -mkNotificationId = do - ni <- fmap Id <$> retrying x10 fun (const (liftIO UUID.nextUUID)) - maybe (throwM err) return ni - where - x10 = limitRetries 10 <> exponentialBackoff 10 - fun = const (return . isNothing) - err = mkError status500 "internal-error" "unable to generate notification ID" + nid <- E.mkNotificationId + E.createTeamNotification tid nid (List1.singleton $ toJSONObject evt) diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index 98344a35462..af64045f7b6 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -65,9 +65,9 @@ module Galley.API.Update ) where +import Control.Error.Util (hush) import Control.Lens import Control.Monad.State -import Control.Monad.Trans.Maybe import Data.Code import Data.Either.Extra (mapRight) import Data.Id @@ -80,11 +80,10 @@ import qualified Data.Set as Set import Data.Time import Galley.API.Action import Galley.API.Error -import Galley.API.LegalHold.Conflicts (guardLegalholdPolicyConflicts) +import Galley.API.LegalHold.Conflicts import Galley.API.Mapping import Galley.API.Message import Galley.API.Util -import Galley.App import qualified Galley.Data.Conversation as Data import Galley.Data.Services as Data import Galley.Data.Types hiding (Conversation) @@ -99,6 +98,7 @@ import qualified Galley.Effects.GundeckAccess as E import qualified Galley.Effects.MemberStore as E import qualified Galley.Effects.ServiceStore as E import qualified Galley.Effects.TeamStore as E +import Galley.Effects.WaiRoutes import Galley.Intra.Push import Galley.Options import Galley.Types @@ -117,6 +117,8 @@ import Network.Wai.Predicate hiding (Error, and, failure, setStatus, _1, _2) import Network.Wai.Utilities hiding (Error) import Polysemy import Polysemy.Error +import Polysemy.Input +import Polysemy.TinyLog import qualified Wire.API.Conversation as Public import qualified Wire.API.Conversation.Code as Public import Wire.API.Conversation.Role (roleNameWireAdmin) @@ -137,13 +139,17 @@ acceptConvH :: Error ConversationError, Error InternalError, GundeckAccess, - MemberStore + Input (Local ()), + Input UTCTime, + MemberStore, + TinyLog ] r => UserId ::: Maybe ConnId ::: ConvId -> - Galley r Response -acceptConvH (usr ::: conn ::: cnv) = - setStatus status200 . json <$> acceptConv usr conn cnv + Sem r Response +acceptConvH (usr ::: conn ::: cnv) = do + lusr <- qualifyLocal usr + setStatus status200 . json <$> acceptConv lusr conn cnv acceptConv :: Members @@ -152,18 +158,20 @@ acceptConv :: Error ConversationError, Error InternalError, GundeckAccess, - MemberStore + Input UTCTime, + MemberStore, + TinyLog ] r => - UserId -> + Local UserId -> Maybe ConnId -> ConvId -> - Galley r Conversation -acceptConv usr conn cnv = do + Sem r Conversation +acceptConv lusr conn cnv = do conv <- - liftSem $ E.getConversation cnv >>= note ConvNotFound - conv' <- acceptOne2One usr conv conn - conversationView usr conv' + E.getConversation cnv >>= note ConvNotFound + conv' <- acceptOne2One lusr conv conn + conversationView lusr conv' blockConvH :: Members @@ -174,7 +182,7 @@ blockConvH :: ] r => UserId ::: ConvId -> - Galley r Response + Sem r Response blockConvH (zusr ::: cnv) = empty <$ blockConv zusr cnv @@ -188,13 +196,13 @@ blockConv :: r => UserId -> ConvId -> - Galley r () + Sem r () blockConv zusr cnv = do - conv <- liftSem $ E.getConversation cnv >>= note ConvNotFound + conv <- E.getConversation cnv >>= note ConvNotFound unless (Data.convType conv `elem` [ConnectConv, One2OneConv]) $ - liftSem . throw . InvalidOp . Data.convType $ conv + throw . InvalidOp . Data.convType $ conv let mems = Data.convLocalMembers conv - when (zusr `isMember` mems) . liftSem $ + when (zusr `isMember` mems) $ E.deleteMembers cnv (UserList [zusr] []) unblockConvH :: @@ -204,13 +212,17 @@ unblockConvH :: Error ConversationError, Error InternalError, GundeckAccess, - MemberStore + Input (Local ()), + Input UTCTime, + MemberStore, + TinyLog ] r => UserId ::: Maybe ConnId ::: ConvId -> - Galley r Response -unblockConvH (usr ::: conn ::: cnv) = - setStatus status200 . json <$> unblockConv usr conn cnv + Sem r Response +unblockConvH (usr ::: conn ::: cnv) = do + lusr <- qualifyLocal usr + setStatus status200 . json <$> unblockConv lusr conn cnv unblockConv :: Members @@ -219,20 +231,22 @@ unblockConv :: Error ConversationError, Error InternalError, GundeckAccess, - MemberStore + Input UTCTime, + MemberStore, + TinyLog ] r => - UserId -> + Local UserId -> Maybe ConnId -> ConvId -> - Galley r Conversation -unblockConv usr conn cnv = do + Sem r Conversation +unblockConv lusr conn cnv = do conv <- - liftSem $ E.getConversation cnv >>= note ConvNotFound + E.getConversation cnv >>= note ConvNotFound unless (Data.convType conv `elem` [ConnectConv, One2OneConv]) $ - liftSem . throw . InvalidOp . Data.convType $ conv - conv' <- acceptOne2One usr conv conn - conversationView usr conv' + throw . InvalidOp . Data.convType $ conv + conv' <- acceptOne2One lusr conv conn + conversationView lusr conv' -- conversation updates @@ -255,17 +269,17 @@ updateConversationAccess :: FederatorAccess, FireAndForget, GundeckAccess, + Input UTCTime, MemberStore, TeamStore ] r => - UserId -> + Local UserId -> ConnId -> Qualified ConvId -> Public.ConversationAccessData -> - Galley r (UpdateResult Event) -updateConversationAccess usr con qcnv update = do - lusr <- qualifyLocal usr + Sem r (UpdateResult Event) +updateConversationAccess lusr con qcnv update = do let doUpdate = foldQualified lusr @@ -286,18 +300,18 @@ updateConversationAccessUnqualified :: FederatorAccess, FireAndForget, GundeckAccess, + Input UTCTime, MemberStore, TeamStore ] r => - UserId -> + Local UserId -> ConnId -> ConvId -> Public.ConversationAccessData -> - Galley r (UpdateResult Event) -updateConversationAccessUnqualified usr zcon cnv update = do - lusr <- qualifyLocal usr - lcnv <- qualifyLocal cnv + Sem r (UpdateResult Event) +updateConversationAccessUnqualified lusr zcon cnv update = do + let lcnv = qualifyAs lusr cnv updateLocalConversationAccess lcnv lusr zcon update updateLocalConversationAccess :: @@ -313,6 +327,7 @@ updateLocalConversationAccess :: FederatorAccess, FireAndForget, GundeckAccess, + Input UTCTime, MemberStore, TeamStore ] @@ -321,7 +336,7 @@ updateLocalConversationAccess :: Local UserId -> ConnId -> Public.ConversationAccessData -> - Galley r (UpdateResult Event) + Sem r (UpdateResult Event) updateLocalConversationAccess lcnv lusr con = getUpdateResult . updateLocalConversation lcnv (qUntagged lusr) (Just con) @@ -332,8 +347,8 @@ updateRemoteConversationAccess :: Local UserId -> ConnId -> Public.ConversationAccessData -> - Galley r (UpdateResult Event) -updateRemoteConversationAccess _ _ _ _ = liftSem $ throw FederationNotImplemented + Sem r (UpdateResult Event) +updateRemoteConversationAccess _ _ _ _ = throw FederationNotImplemented updateConversationReceiptMode :: Members @@ -343,17 +358,17 @@ updateConversationReceiptMode :: Error InvalidInput, ExternalAccess, FederatorAccess, - GundeckAccess + GundeckAccess, + Input UTCTime ] r => Members '[Error FederationError] r => - UserId -> + Local UserId -> ConnId -> Qualified ConvId -> Public.ConversationReceiptModeUpdate -> - Galley r (UpdateResult Event) -updateConversationReceiptMode usr zcon qcnv update = do - lusr <- qualifyLocal usr + Sem r (UpdateResult Event) +updateConversationReceiptMode lusr zcon qcnv update = do let doUpdate = foldQualified lusr @@ -369,17 +384,17 @@ updateConversationReceiptModeUnqualified :: Error InvalidInput, ExternalAccess, FederatorAccess, - GundeckAccess + GundeckAccess, + Input UTCTime ] r => - UserId -> + Local UserId -> ConnId -> ConvId -> Public.ConversationReceiptModeUpdate -> - Galley r (UpdateResult Event) -updateConversationReceiptModeUnqualified usr zcon cnv update = do - lusr <- qualifyLocal usr - lcnv <- qualifyLocal cnv + Sem r (UpdateResult Event) +updateConversationReceiptModeUnqualified lusr zcon cnv update = do + let lcnv = qualifyAs lusr cnv updateLocalConversationReceiptMode lcnv lusr zcon update updateLocalConversationReceiptMode :: @@ -390,14 +405,15 @@ updateLocalConversationReceiptMode :: Error InvalidInput, ExternalAccess, FederatorAccess, - GundeckAccess + GundeckAccess, + Input UTCTime ] r => Local ConvId -> Local UserId -> ConnId -> Public.ConversationReceiptModeUpdate -> - Galley r (UpdateResult Event) + Sem r (UpdateResult Event) updateLocalConversationReceiptMode lcnv lusr con update = getUpdateResult $ updateLocalConversation lcnv (qUntagged lusr) (Just con) update @@ -408,8 +424,8 @@ updateRemoteConversationReceiptMode :: Local UserId -> ConnId -> Public.ConversationReceiptModeUpdate -> - Galley r (UpdateResult Event) -updateRemoteConversationReceiptMode _ _ _ _ = liftSem $ throw FederationNotImplemented + Sem r (UpdateResult Event) +updateRemoteConversationReceiptMode _ _ _ _ = throw FederationNotImplemented updateConversationMessageTimerUnqualified :: Members @@ -419,17 +435,17 @@ updateConversationMessageTimerUnqualified :: Error InvalidInput, ExternalAccess, FederatorAccess, - GundeckAccess + GundeckAccess, + Input UTCTime ] r => - UserId -> + Local UserId -> ConnId -> ConvId -> Public.ConversationMessageTimerUpdate -> - Galley r (UpdateResult Event) -updateConversationMessageTimerUnqualified usr zcon cnv update = do - lusr <- qualifyLocal usr - lcnv <- qualifyLocal cnv + Sem r (UpdateResult Event) +updateConversationMessageTimerUnqualified lusr zcon cnv update = do + let lcnv = qualifyAs lusr cnv updateLocalConversationMessageTimer lusr zcon lcnv update updateConversationMessageTimer :: @@ -441,20 +457,20 @@ updateConversationMessageTimer :: Error InvalidInput, ExternalAccess, FederatorAccess, - GundeckAccess + GundeckAccess, + Input UTCTime ] r => - UserId -> + Local UserId -> ConnId -> Qualified ConvId -> Public.ConversationMessageTimerUpdate -> - Galley r (UpdateResult Event) -updateConversationMessageTimer usr zcon qcnv update = do - lusr <- qualifyLocal usr + Sem r (UpdateResult Event) +updateConversationMessageTimer lusr zcon qcnv update = do foldQualified lusr (updateLocalConversationMessageTimer lusr zcon) - (\_ _ -> liftSem (throw FederationNotImplemented)) + (\_ _ -> throw FederationNotImplemented) qcnv update @@ -466,14 +482,15 @@ updateLocalConversationMessageTimer :: Error InvalidInput, ExternalAccess, FederatorAccess, - GundeckAccess + GundeckAccess, + Input UTCTime ] r => Local UserId -> ConnId -> Local ConvId -> Public.ConversationMessageTimerUpdate -> - Galley r (UpdateResult Event) + Sem r (UpdateResult Event) updateLocalConversationMessageTimer lusr con lcnv update = getUpdateResult $ updateLocalConversation lcnv (qUntagged lusr) (Just con) update @@ -490,19 +507,20 @@ deleteLocalConversation :: ExternalAccess, FederatorAccess, GundeckAccess, + Input UTCTime, TeamStore ] r => Local UserId -> ConnId -> Local ConvId -> - Galley r (UpdateResult Event) + Sem r (UpdateResult Event) deleteLocalConversation lusr con lcnv = getUpdateResult $ updateLocalConversation lcnv (qUntagged lusr) (Just con) ConversationDelete -getUpdateResult :: Functor m => MaybeT m a -> m (UpdateResult a) -getUpdateResult = fmap (maybe Unchanged Updated) . runMaybeT +getUpdateResult :: Sem (Error NoChanges ': r) a -> Sem r (UpdateResult a) +getUpdateResult = fmap (either (const Unchanged) Updated) . runError addCodeH :: Members @@ -510,13 +528,17 @@ addCodeH :: ConversationStore, Error ConversationError, ExternalAccess, - GundeckAccess + GundeckAccess, + Input (Local ()), + Input UTCTime ] r => UserId ::: ConnId ::: ConvId -> - Galley r Response -addCodeH (usr ::: zcon ::: cnv) = - addCode usr zcon cnv <&> \case + Sem r Response +addCodeH (usr ::: zcon ::: cnv) = do + lusr <- qualifyLocal usr + lcnv <- qualifyLocal cnv + addCode lusr zcon lcnv <&> \case CodeAdded event -> json event & setStatus status201 CodeAlreadyExisted conversationCode -> json conversationCode & setStatus status200 @@ -531,39 +553,37 @@ addCode :: ConversationStore, Error ConversationError, ExternalAccess, - GundeckAccess + GundeckAccess, + Input UTCTime ] r => - UserId -> + Local UserId -> ConnId -> - ConvId -> - Galley r AddCodeResult -addCode usr zcon cnv = do - localDomain <- viewFederationDomain - let qcnv = Qualified cnv localDomain - qusr = Qualified usr localDomain - conv <- liftSem $ E.getConversation cnv >>= note ConvNotFound - ensureConvMember (Data.convLocalMembers conv) usr - liftSem $ ensureAccess conv CodeAccess + Local ConvId -> + Sem r AddCodeResult +addCode lusr zcon lcnv = do + conv <- E.getConversation (tUnqualified lcnv) >>= note ConvNotFound + ensureConvMember (Data.convLocalMembers conv) (tUnqualified lusr) + ensureAccess conv CodeAccess let (bots, users) = localBotsAndUsers $ Data.convLocalMembers conv - key <- mkKey cnv - mCode <- liftSem $ E.getCode key ReusableCode + key <- E.makeKey (tUnqualified lcnv) + mCode <- E.getCode key ReusableCode case mCode of Nothing -> do - code <- generate cnv ReusableCode (Timeout 3600 * 24 * 365) -- one year TODO: configurable - liftSem $ E.createCode code - now <- liftIO getCurrentTime + code <- E.generateCode (tUnqualified lcnv) ReusableCode (Timeout 3600 * 24 * 365) -- one year FUTUREWORK: configurable + E.createCode code + now <- input conversationCode <- createCode code - let event = Event ConvCodeUpdate qcnv qusr now (EdConvCodeUpdate conversationCode) - pushConversationEvent (Just zcon) event (map lmId users) bots + let event = Event ConvCodeUpdate (qUntagged lcnv) (qUntagged lusr) now (EdConvCodeUpdate conversationCode) + pushConversationEvent (Just zcon) event (qualifyAs lusr (map lmId users)) bots pure $ CodeAdded event Just code -> do conversationCode <- createCode code pure $ CodeAlreadyExisted conversationCode where - createCode :: Code -> Galley r ConversationCode + createCode :: Code -> Sem r ConversationCode createCode code = do - urlPrefix <- view $ options . optSettings . setConversationCodeURI + urlPrefix <- E.getConversationCodeURI return $ mkConversationCode (codeKey code) (codeValue code) urlPrefix rmCodeH :: @@ -572,13 +592,17 @@ rmCodeH :: ConversationStore, Error ConversationError, ExternalAccess, - GundeckAccess + GundeckAccess, + Input (Local ()), + Input UTCTime ] r => UserId ::: ConnId ::: ConvId -> - Galley r Response -rmCodeH (usr ::: zcon ::: cnv) = - setStatus status200 . json <$> rmCode usr zcon cnv + Sem r Response +rmCodeH (usr ::: zcon ::: cnv) = do + lusr <- qualifyLocal usr + lcnv <- qualifyLocal cnv + setStatus status200 . json <$> rmCode lusr zcon lcnv rmCode :: Members @@ -586,27 +610,25 @@ rmCode :: ConversationStore, Error ConversationError, ExternalAccess, - GundeckAccess + GundeckAccess, + Input UTCTime ] r => - UserId -> + Local UserId -> ConnId -> - ConvId -> - Galley r Public.Event -rmCode usr zcon cnv = do - localDomain <- viewFederationDomain - let qcnv = Qualified cnv localDomain - qusr = Qualified usr localDomain + Local ConvId -> + Sem r Public.Event +rmCode lusr zcon lcnv = do conv <- - liftSem $ E.getConversation cnv >>= note ConvNotFound - ensureConvMember (Data.convLocalMembers conv) usr - liftSem $ ensureAccess conv CodeAccess + E.getConversation (tUnqualified lcnv) >>= note ConvNotFound + ensureConvMember (Data.convLocalMembers conv) (tUnqualified lusr) + ensureAccess conv CodeAccess let (bots, users) = localBotsAndUsers $ Data.convLocalMembers conv - key <- mkKey cnv - liftSem $ E.deleteCode key ReusableCode - now <- liftIO getCurrentTime - let event = Event ConvCodeDelete qcnv qusr now EdConvCodeDelete - pushConversationEvent (Just zcon) event (map lmId users) bots + key <- E.makeKey (tUnqualified lcnv) + E.deleteCode key ReusableCode + now <- input + let event = Event ConvCodeDelete (qUntagged lcnv) (qUntagged lusr) now EdConvCodeDelete + pushConversationEvent (Just zcon) event (qualifyAs lusr (map lmId users)) bots pure event getCodeH :: @@ -618,7 +640,7 @@ getCodeH :: ] r => UserId ::: ConvId -> - Galley r Response + Sem r Response getCodeH (usr ::: cnv) = setStatus status200 . json <$> getCode usr cnv @@ -632,25 +654,25 @@ getCode :: r => UserId -> ConvId -> - Galley r Public.ConversationCode + Sem r Public.ConversationCode getCode usr cnv = do conv <- - liftSem $ E.getConversation cnv >>= note ConvNotFound - liftSem $ ensureAccess conv CodeAccess + E.getConversation cnv >>= note ConvNotFound + ensureAccess conv CodeAccess ensureConvMember (Data.convLocalMembers conv) usr - key <- mkKey cnv - c <- liftSem $ E.getCode key ReusableCode >>= note CodeNotFound + key <- E.makeKey cnv + c <- E.getCode key ReusableCode >>= note CodeNotFound returnCode c -returnCode :: Code -> Galley r Public.ConversationCode +returnCode :: Member CodeStore r => Code -> Sem r Public.ConversationCode returnCode c = do - urlPrefix <- view $ options . optSettings . setConversationCodeURI + urlPrefix <- E.getConversationCodeURI pure $ Public.mkConversationCode (codeKey c) (codeValue c) urlPrefix checkReusableCodeH :: - Members '[CodeStore, Error CodeError, Error InvalidInput] r => + Members '[CodeStore, Error CodeError, WaiRoutes] r => JsonRequest Public.ConversationCode -> - Galley r Response + Sem r Response checkReusableCodeH req = do convCode <- fromJsonBody req checkReusableCode convCode @@ -659,7 +681,7 @@ checkReusableCodeH req = do checkReusableCode :: Members '[CodeStore, Error CodeError] r => Public.ConversationCode -> - Galley r () + Sem r () checkReusableCode convCode = void $ verifyReusableCode convCode @@ -672,20 +694,23 @@ joinConversationByReusableCodeH :: Error ActionError, Error CodeError, Error ConversationError, - Error FederationError, - Error InvalidInput, Error NotATeamMember, ExternalAccess, GundeckAccess, + Input (Local ()), + Input Opts, + Input UTCTime, MemberStore, - TeamStore + TeamStore, + WaiRoutes ] r => UserId ::: ConnId ::: JsonRequest Public.ConversationCode -> - Galley r Response + Sem r Response joinConversationByReusableCodeH (zusr ::: zcon ::: req) = do + lusr <- qualifyLocal zusr convCode <- fromJsonBody req - handleUpdateResult <$> joinConversationByReusableCode zusr zcon convCode + handleUpdateResult <$> joinConversationByReusableCode lusr zcon convCode joinConversationByReusableCode :: Members @@ -695,44 +720,46 @@ joinConversationByReusableCode :: Error ActionError, Error CodeError, Error ConversationError, - Error FederationError, - Error InvalidInput, Error NotATeamMember, FederatorAccess, ExternalAccess, GundeckAccess, + Input Opts, + Input UTCTime, MemberStore, TeamStore ] r => - UserId -> + Local UserId -> ConnId -> Public.ConversationCode -> - Galley r (UpdateResult Event) -joinConversationByReusableCode zusr zcon convCode = do + Sem r (UpdateResult Event) +joinConversationByReusableCode lusr zcon convCode = do c <- verifyReusableCode convCode - joinConversation zusr zcon (codeConversation c) CodeAccess + joinConversation lusr zcon (codeConversation c) CodeAccess joinConversationByIdH :: Members '[ BrigAccess, - ConversationStore, FederatorAccess, + ConversationStore, Error ActionError, Error ConversationError, - Error FederationError, - Error InvalidInput, Error NotATeamMember, ExternalAccess, GundeckAccess, + Input (Local ()), + Input Opts, + Input UTCTime, MemberStore, TeamStore ] r => UserId ::: ConnId ::: ConvId ::: JSON -> - Galley r Response -joinConversationByIdH (zusr ::: zcon ::: cnv ::: _) = - handleUpdateResult <$> joinConversationById zusr zcon cnv + Sem r Response +joinConversationByIdH (zusr ::: zcon ::: cnv ::: _) = do + lusr <- qualifyLocal zusr + handleUpdateResult <$> joinConversationById lusr zcon cnv joinConversationById :: Members @@ -741,21 +768,21 @@ joinConversationById :: ConversationStore, Error ActionError, Error ConversationError, - Error FederationError, - Error InvalidInput, Error NotATeamMember, ExternalAccess, GundeckAccess, + Input Opts, + Input UTCTime, MemberStore, TeamStore ] r => - UserId -> + Local UserId -> ConnId -> ConvId -> - Galley r (UpdateResult Event) -joinConversationById zusr zcon cnv = - joinConversation zusr zcon cnv LinkAccess + Sem r (UpdateResult Event) +joinConversationById lusr zcon cnv = + joinConversation lusr zcon cnv LinkAccess joinConversation :: Members @@ -764,41 +791,39 @@ joinConversation :: FederatorAccess, Error ActionError, Error ConversationError, - Error FederationError, - Error InvalidInput, Error NotATeamMember, ExternalAccess, GundeckAccess, + Input Opts, + Input UTCTime, MemberStore, TeamStore ] r => - UserId -> + Local UserId -> ConnId -> ConvId -> Access -> - Galley r (UpdateResult Event) -joinConversation zusr zcon cnv access = do - lusr <- qualifyLocal zusr - lcnv <- qualifyLocal cnv - conv <- ensureConversationAccess zusr cnv access - liftSem . ensureGroupConversation $ conv + Sem r (UpdateResult Event) +joinConversation lusr zcon cnv access = do + let lcnv = qualifyAs lusr cnv + conv <- ensureConversationAccess (tUnqualified lusr) cnv access + ensureGroupConversation $ conv -- FUTUREWORK: remote users? - ensureMemberLimit (toList $ Data.convLocalMembers conv) [zusr] + ensureMemberLimit (toList $ Data.convLocalMembers conv) [tUnqualified lusr] getUpdateResult $ do -- NOTE: When joining conversations, all users become members -- as this is our desired behavior for these types of conversations -- where there is no way to control who joins, etc. - let users = filter (notIsConvMember lusr conv) [zusr] + let users = filter (notIsConvMember lusr conv) [tUnqualified lusr] (extraTargets, action) <- addMembersToLocalConversation lcnv (UserList users []) roleNameWireMember - lift $ - notifyConversationAction - (qUntagged lusr) - (Just zcon) - lcnv - (convBotsAndMembers conv <> extraTargets) - (conversationAction action) + notifyConversationAction + (qUntagged lusr) + (Just zcon) + lcnv + (convBotsAndMembers conv <> extraTargets) + (conversationAction action) addMembersUnqualified :: Members @@ -813,19 +838,21 @@ addMembersUnqualified :: ExternalAccess, FederatorAccess, GundeckAccess, + Input Opts, + Input UTCTime, LegalHoldStore, MemberStore, TeamStore ] r => - UserId -> + Local UserId -> ConnId -> ConvId -> Public.Invite -> - Galley r (UpdateResult Event) -addMembersUnqualified zusr zcon cnv (Public.Invite users role) = do - qusers <- traverse (fmap qUntagged . qualifyLocal) (toNonEmpty users) - addMembers zusr zcon cnv (Public.InviteQualified qusers role) + Sem r (UpdateResult Event) +addMembersUnqualified lusr zcon cnv (Public.Invite users role) = do + let qusers = fmap (qUntagged . qualifyAs lusr) (toNonEmpty users) + addMembers lusr zcon cnv (Public.InviteQualified qusers role) addMembers :: Members @@ -840,19 +867,20 @@ addMembers :: ExternalAccess, FederatorAccess, GundeckAccess, + Input Opts, + Input UTCTime, LegalHoldStore, MemberStore, TeamStore ] r => - UserId -> + Local UserId -> ConnId -> ConvId -> Public.InviteQualified -> - Galley r (UpdateResult Event) -addMembers zusr zcon cnv (Public.InviteQualified users role) = do - lusr <- qualifyLocal zusr - lcnv <- qualifyLocal cnv + Sem r (UpdateResult Event) +addMembers lusr zcon cnv (Public.InviteQualified users role) = do + let lcnv = qualifyAs lusr cnv getUpdateResult $ updateLocalConversation lcnv (qUntagged lusr) (Just zcon) $ ConversationJoin users role @@ -861,39 +889,37 @@ updateSelfMember :: Members '[ ConversationStore, Error ConversationError, - GundeckAccess, ExternalAccess, + GundeckAccess, + Input UTCTime, MemberStore ] r => - UserId -> + Local UserId -> ConnId -> Qualified ConvId -> Public.MemberUpdate -> - Galley r () -updateSelfMember zusr zcon qcnv update = do - lusr <- qualifyLocal zusr - exists <- liftSem $ foldQualified lusr checkLocalMembership checkRemoteMembership qcnv lusr - liftSem . unless exists . throw $ ConvNotFound - liftSem $ E.setSelfMember qcnv lusr update - now <- liftIO getCurrentTime + Sem r () +updateSelfMember lusr zcon qcnv update = do + exists <- foldQualified lusr checkLocalMembership checkRemoteMembership qcnv + unless exists . throw $ ConvNotFound + E.setSelfMember qcnv lusr update + now <- input let e = Event MemberStateUpdate qcnv (qUntagged lusr) now (EdMemberUpdate (updateData lusr)) - pushConversationEvent (Just zcon) e [zusr] [] + pushConversationEvent (Just zcon) e (fmap pure lusr) [] where checkLocalMembership :: Members '[MemberStore] r => Local ConvId -> - Local UserId -> Sem r Bool - checkLocalMembership lcnv lusr = + checkLocalMembership lcnv = isMember (tUnqualified lusr) <$> E.getLocalMembers (tUnqualified lcnv) checkRemoteMembership :: Members '[ConversationStore] r => Remote ConvId -> - Local UserId -> Sem r Bool - checkRemoteMembership rcnv lusr = + checkRemoteMembership rcnv = isJust . Map.lookup rcnv <$> E.getRemoteConversationStatus (tUnqualified lusr) [rcnv] updateData luid = @@ -914,17 +940,18 @@ updateUnqualifiedSelfMember :: Error ConversationError, ExternalAccess, GundeckAccess, + Input UTCTime, MemberStore ] r => - UserId -> + Local UserId -> ConnId -> ConvId -> Public.MemberUpdate -> - Galley r () -updateUnqualifiedSelfMember zusr zcon cnv update = do - lcnv <- qualifyLocal cnv - updateSelfMember zusr zcon (qUntagged lcnv) update + Sem r () +updateUnqualifiedSelfMember lusr zcon cnv update = do + let lcnv = qualifyAs lusr cnv + updateSelfMember lusr zcon (qUntagged lcnv) update updateOtherMemberUnqualified :: Members @@ -935,19 +962,19 @@ updateOtherMemberUnqualified :: ExternalAccess, FederatorAccess, GundeckAccess, + Input UTCTime, MemberStore ] r => - UserId -> + Local UserId -> ConnId -> ConvId -> UserId -> Public.OtherMemberUpdate -> - Galley r () -updateOtherMemberUnqualified zusr zcon cnv victim update = do - lusr <- qualifyLocal zusr - lcnv <- qualifyLocal cnv - lvictim <- qualifyLocal victim + Sem r () +updateOtherMemberUnqualified lusr zcon cnv victim update = do + let lcnv = qualifyAs lusr cnv + let lvictim = qualifyAs lusr victim updateOtherMemberLocalConv lcnv lusr zcon (qUntagged lvictim) update updateOtherMember :: @@ -960,17 +987,17 @@ updateOtherMember :: ExternalAccess, FederatorAccess, GundeckAccess, + Input UTCTime, MemberStore ] r => - UserId -> + Local UserId -> ConnId -> Qualified ConvId -> Qualified UserId -> Public.OtherMemberUpdate -> - Galley r () -updateOtherMember zusr zcon qcnv qvictim update = do - lusr <- qualifyLocal zusr + Sem r () +updateOtherMember lusr zcon qcnv qvictim update = do let doUpdate = foldQualified lusr updateOtherMemberLocalConv updateOtherMemberRemoteConv doUpdate qcnv lusr zcon qvictim update @@ -983,6 +1010,7 @@ updateOtherMemberLocalConv :: ExternalAccess, FederatorAccess, GundeckAccess, + Input UTCTime, MemberStore ] r => @@ -991,9 +1019,9 @@ updateOtherMemberLocalConv :: ConnId -> Qualified UserId -> Public.OtherMemberUpdate -> - Galley r () + Sem r () updateOtherMemberLocalConv lcnv lusr con qvictim update = void . getUpdateResult $ do - lift . liftSem . when (qUntagged lusr == qvictim) $ + when (qUntagged lusr == qvictim) $ throw InvalidTargetUserOp updateLocalConversation lcnv (qUntagged lusr) (Just con) $ ConversationMemberUpdate qvictim update @@ -1005,8 +1033,8 @@ updateOtherMemberRemoteConv :: ConnId -> Qualified UserId -> Public.OtherMemberUpdate -> - Galley r () -updateOtherMemberRemoteConv _ _ _ _ _ = liftSem $ throw FederationNotImplemented + Sem r () +updateOtherMemberRemoteConv _ _ _ _ _ = throw FederationNotImplemented removeMemberUnqualified :: Members @@ -1017,18 +1045,19 @@ removeMemberUnqualified :: ExternalAccess, FederatorAccess, GundeckAccess, + Input UTCTime, MemberStore ] r => - UserId -> + Local UserId -> ConnId -> ConvId -> UserId -> - Galley r RemoveFromConversationResponse -removeMemberUnqualified zusr con cnv victim = do - lcnv <- qualifyLocal cnv - lvictim <- qualifyLocal victim - removeMemberQualified zusr con (qUntagged lcnv) (qUntagged lvictim) + Sem r RemoveFromConversationResponse +removeMemberUnqualified lusr con cnv victim = do + let lvictim = qualifyAs lusr victim + lcnv = qualifyAs lusr cnv + removeMemberQualified lusr con (qUntagged lcnv) (qUntagged lvictim) removeMemberQualified :: Members @@ -1039,41 +1068,39 @@ removeMemberQualified :: ExternalAccess, FederatorAccess, GundeckAccess, + Input UTCTime, MemberStore ] r => - UserId -> + Local UserId -> ConnId -> Qualified ConvId -> Qualified UserId -> - Galley r RemoveFromConversationResponse -removeMemberQualified zusr con qcnv victim = do - lusr <- qualifyLocal zusr + Sem r RemoveFromConversationResponse +removeMemberQualified lusr con qcnv victim = do foldQualified lusr removeMemberFromLocalConv removeMemberFromRemoteConv qcnv lusr (Just con) victim removeMemberFromRemoteConv :: - Members '[FederatorAccess] r => + Members '[FederatorAccess, Input UTCTime] r => Remote ConvId -> Local UserId -> Maybe ConnId -> Qualified UserId -> - Galley r RemoveFromConversationResponse + Sem r RemoveFromConversationResponse removeMemberFromRemoteConv cnv lusr _ victim - | qUntagged lusr == victim = - do - let lc = FederatedGalley.LeaveConversationRequest (tUnqualified cnv) (qUnqualified victim) - let rpc = - FederatedGalley.leaveConversation - FederatedGalley.clientRoutes - (qDomain victim) - lc - t <- liftIO getCurrentTime - let successEvent = - Event MemberLeave (qUntagged cnv) (qUntagged lusr) t $ - EdMembersLeave (QualifiedUserIdList [victim]) - liftSem $ - mapRight (const successEvent) . FederatedGalley.leaveResponse - <$> E.runFederated cnv rpc + | qUntagged lusr == victim = do + let lc = FederatedGalley.LeaveConversationRequest (tUnqualified cnv) (qUnqualified victim) + let rpc = + FederatedGalley.leaveConversation + FederatedGalley.clientRoutes + (qDomain victim) + lc + t <- input + let successEvent = + Event MemberLeave (qUntagged cnv) (qUntagged lusr) t $ + EdMembersLeave (QualifiedUserIdList [victim]) + mapRight (const successEvent) . FederatedGalley.leaveResponse + <$> E.runFederated cnv rpc | otherwise = pure . Left $ RemoveFromConversationErrorRemovalNotAllowed -- | Remove a member from a local conversation. @@ -1086,6 +1113,7 @@ removeMemberFromLocalConv :: ExternalAccess, FederatorAccess, GundeckAccess, + Input UTCTime, MemberStore ] r => @@ -1093,11 +1121,11 @@ removeMemberFromLocalConv :: Local UserId -> Maybe ConnId -> Qualified UserId -> - Galley r RemoveFromConversationResponse + Sem r RemoveFromConversationResponse removeMemberFromLocalConv lcnv lusr con victim = -- FUTUREWORK: actually return errors as part of the response instead of throwing - fmap (maybe (Left RemoveFromConversationErrorUnchanged) Right) - . runMaybeT + runError + . mapError @NoChanges (const (RemoveFromConversationErrorUnchanged)) . updateLocalConversation lcnv (qUntagged lusr) con . ConversationLeave . pure @@ -1118,9 +1146,9 @@ handleOtrResult :: ] r => OtrResult -> - Galley r Response + Sem r Response handleOtrResult = - liftSem . \case + \case OtrSent m -> pure $ json m & setStatus status201 OtrMissingRecipients m -> pure $ json m & setStatus status412 OtrUnknownClient _ -> throw UnknownClient @@ -1128,48 +1156,53 @@ handleOtrResult = postBotMessageH :: Members - '[ BotAccess, - BrigAccess, + '[ BrigAccess, ClientStore, ConversationStore, Error ClientError, Error ConversationError, Error LegalHoldError, - Error InvalidInput, - FederatorAccess, GundeckAccess, ExternalAccess, + Input (Local ()), + Input Opts, + Input UTCTime, MemberStore, - TeamStore + TeamStore, + TinyLog, + WaiRoutes ] r => BotId ::: ConvId ::: Public.OtrFilterMissing ::: JsonRequest Public.NewOtrMessage ::: JSON -> - Galley r Response -postBotMessageH (zbot ::: zcnv ::: val ::: req ::: _) = do + Sem r Response +postBotMessageH (zbot ::: cnv ::: val ::: req ::: _) = do + lbot <- qualifyLocal zbot + lcnv <- qualifyLocal cnv message <- fromJsonBody req let val' = allowOtrFilterMissingInBody val message - handleOtrResult =<< postBotMessage zbot zcnv val' message + handleOtrResult =<< postBotMessage lbot lcnv val' message postBotMessage :: Members - '[ BotAccess, - BrigAccess, + '[ BrigAccess, ClientStore, ConversationStore, Error LegalHoldError, ExternalAccess, - FederatorAccess, GundeckAccess, + Input Opts, + Input UTCTime, MemberStore, - TeamStore + TeamStore, + TinyLog ] r => - BotId -> - ConvId -> + Local BotId -> + Local ConvId -> Public.OtrFilterMissing -> Public.NewOtrMessage -> - Galley r OtrResult -postBotMessage zbot = postNewOtrMessage Bot (botUserId zbot) Nothing + Sem r OtrResult +postBotMessage zbot = postNewOtrMessage Bot (fmap botUserId zbot) Nothing postProteusMessage :: Members @@ -1180,20 +1213,22 @@ postProteusMessage :: FederatorAccess, GundeckAccess, ExternalAccess, + Input Opts, + Input UTCTime, MemberStore, - TeamStore + TeamStore, + TinyLog ] r => - UserId -> + Local UserId -> ConnId -> Qualified ConvId -> RawProto Public.QualifiedNewOtrMessage -> - Galley r (Public.PostOtrResponse Public.MessageSendingStatus) -postProteusMessage zusr zcon conv msg = do - sender <- qualifyLocal zusr + Sem r (Public.PostOtrResponse Public.MessageSendingStatus) +postProteusMessage sender zcon conv msg = runLocalInput sender $ do foldQualified sender - (\c -> postQualifiedOtrMessage User (qUntagged sender) (Just zcon) (tUnqualified c) (rpValue msg)) + (\c -> postQualifiedOtrMessage User (qUntagged sender) (Just zcon) c (rpValue msg)) (\c -> postRemoteOtrMessage (qUntagged sender) c (rpRaw msg)) conv @@ -1207,20 +1242,23 @@ postOtrMessageUnqualified :: GundeckAccess, ExternalAccess, MemberStore, - TeamStore + Input Opts, + Input UTCTime, + TeamStore, + TinyLog ] r => - UserId -> + Local UserId -> ConnId -> ConvId -> Maybe Public.IgnoreMissing -> Maybe Public.ReportMissing -> Public.NewOtrMessage -> - Galley r (Public.PostOtrResponse Public.ClientMismatch) -postOtrMessageUnqualified zusr zcon cnv ignoreMissing reportMissing message = do - localDomain <- viewFederationDomain - let sender = Qualified zusr localDomain - qualifiedRecipients = + Sem r (Public.PostOtrResponse Public.ClientMismatch) +postOtrMessageUnqualified sender zcon cnv ignoreMissing reportMissing message = do + let lcnv = qualifyAs sender cnv + localDomain = tDomain sender + let qualifiedRecipients = Public.QualifiedOtrRecipients . QualifiedUserClientMap . Map.singleton localDomain @@ -1240,8 +1278,9 @@ postOtrMessageUnqualified zusr zcon cnv ignoreMissing reportMissing message = do Public.qualifiedNewOtrData = maybe mempty fromBase64TextLenient (newOtrData message), Public.qualifiedNewOtrClientMismatchStrategy = clientMismatchStrategy } - unqualify localDomain - <$> postQualifiedOtrMessage User sender (Just zcon) cnv qualifiedMessage + runLocalInput sender $ + unqualify localDomain + <$> postQualifiedOtrMessage User (qUntagged sender) (Just zcon) lcnv qualifiedMessage postProtoOtrBroadcastH :: Members @@ -1251,19 +1290,23 @@ postProtoOtrBroadcastH :: Error ClientError, Error ConversationError, Error LegalHoldError, - Error InvalidInput, - Error NotATeamMember, Error TeamError, GundeckAccess, - TeamStore + Input (Local ()), + Input Opts, + Input UTCTime, + TeamStore, + TinyLog, + WaiRoutes ] r => UserId ::: ConnId ::: Public.OtrFilterMissing ::: Request ::: JSON -> - Galley r Response + Sem r Response postProtoOtrBroadcastH (zusr ::: zcon ::: val ::: req ::: _) = do + lusr <- qualifyLocal zusr message <- Public.protoToNewOtrMessage <$> fromProtoBody req let val' = allowOtrFilterMissingInBody val message - handleOtrResult =<< postOtrBroadcast zusr zcon val' message + handleOtrResult =<< postOtrBroadcast lusr zcon val' message postOtrBroadcastH :: Members @@ -1273,19 +1316,23 @@ postOtrBroadcastH :: Error ClientError, Error ConversationError, Error LegalHoldError, - Error InvalidInput, - Error NotATeamMember, Error TeamError, GundeckAccess, - TeamStore + Input (Local ()), + Input Opts, + Input UTCTime, + TeamStore, + TinyLog, + WaiRoutes ] r => UserId ::: ConnId ::: Public.OtrFilterMissing ::: JsonRequest Public.NewOtrMessage -> - Galley r Response + Sem r Response postOtrBroadcastH (zusr ::: zcon ::: val ::: req) = do + lusr <- qualifyLocal zusr message <- fromJsonBody req let val' = allowOtrFilterMissingInBody val message - handleOtrResult =<< postOtrBroadcast zusr zcon val' message + handleOtrResult =<< postOtrBroadcast lusr zcon val' message postOtrBroadcast :: Members @@ -1293,18 +1340,20 @@ postOtrBroadcast :: ClientStore, Error ActionError, Error LegalHoldError, - Error NotATeamMember, Error TeamError, GundeckAccess, - TeamStore + Input Opts, + Input UTCTime, + TeamStore, + TinyLog ] r => - UserId -> + Local UserId -> ConnId -> Public.OtrFilterMissing -> Public.NewOtrMessage -> - Galley r OtrResult -postOtrBroadcast zusr zcon = postNewOtrBroadcast zusr (Just zcon) + Sem r OtrResult +postOtrBroadcast lusr zcon = postNewOtrBroadcast lusr (Just zcon) -- internal OTR helpers @@ -1323,58 +1372,57 @@ postNewOtrBroadcast :: ClientStore, Error ActionError, Error LegalHoldError, - Error NotATeamMember, Error TeamError, + Input Opts, + Input UTCTime, GundeckAccess, - TeamStore + TeamStore, + TinyLog ] r => - UserId -> + Local UserId -> Maybe ConnId -> OtrFilterMissing -> NewOtrMessage -> - Galley r OtrResult -postNewOtrBroadcast usr con val msg = do - localDomain <- viewFederationDomain - let qusr = Qualified usr localDomain - sender = newOtrSender msg + Sem r OtrResult +postNewOtrBroadcast lusr con val msg = do + let sender = newOtrSender msg recvrs = newOtrRecipients msg - now <- liftIO getCurrentTime - withValidOtrBroadcastRecipients usr sender recvrs val now $ \rs -> do - let (_, toUsers) = foldr (newMessage qusr con Nothing msg now) ([], []) rs - liftSem $ E.push (catMaybes toUsers) + now <- input + withValidOtrBroadcastRecipients (tUnqualified lusr) sender recvrs val now $ \rs -> do + let (_, toUsers) = foldr (newMessage (qUntagged lusr) con Nothing msg now) ([], []) rs + E.push (catMaybes toUsers) postNewOtrMessage :: Members - '[ BotAccess, - BrigAccess, + '[ BrigAccess, ClientStore, ConversationStore, Error LegalHoldError, ExternalAccess, GundeckAccess, + Input Opts, + Input UTCTime, MemberStore, - TeamStore + TeamStore, + TinyLog ] r => UserType -> - UserId -> + Local UserId -> Maybe ConnId -> - ConvId -> + Local ConvId -> OtrFilterMissing -> NewOtrMessage -> - Galley r OtrResult -postNewOtrMessage utype usr con cnv val msg = do - localDomain <- viewFederationDomain - let qusr = Qualified usr localDomain - qcnv = Qualified cnv localDomain - sender = newOtrSender msg + Sem r OtrResult +postNewOtrMessage utype lusr con lcnv val msg = do + let sender = newOtrSender msg recvrs = newOtrRecipients msg - now <- liftIO getCurrentTime - withValidOtrRecipients utype usr sender cnv recvrs val now $ \rs -> liftSem $ do - let (toBots, toUsers) = foldr (newMessage qusr con (Just qcnv) msg now) ([], []) rs + now <- input + withValidOtrRecipients utype (tUnqualified lusr) sender (tUnqualified lcnv) recvrs val now $ \rs -> do + let (toBots, toUsers) = foldr (newMessage (qUntagged lusr) con (Just (qUntagged lcnv)) msg now) ([], []) rs E.push (catMaybes toUsers) - E.deliverAndDeleteAsync cnv toBots + E.deliverAndDeleteAsync (tUnqualified lcnv) toBots newMessage :: Qualified UserId -> @@ -1420,20 +1468,20 @@ updateConversationName :: Error InvalidInput, ExternalAccess, FederatorAccess, - GundeckAccess + GundeckAccess, + Input UTCTime ] r => - UserId -> + Local UserId -> ConnId -> Qualified ConvId -> Public.ConversationRename -> - Galley r (Maybe Public.Event) -updateConversationName zusr zcon qcnv convRename = do - lusr <- qualifyLocal zusr + Sem r (Maybe Public.Event) +updateConversationName lusr zcon qcnv convRename = do foldQualified lusr (updateLocalConversationName lusr zcon) - (\_ _ -> liftSem (throw FederationNotImplemented)) + (\_ _ -> throw FederationNotImplemented) qcnv convRename @@ -1445,17 +1493,17 @@ updateUnqualifiedConversationName :: Error InvalidInput, ExternalAccess, FederatorAccess, - GundeckAccess + GundeckAccess, + Input UTCTime ] r => - UserId -> + Local UserId -> ConnId -> ConvId -> Public.ConversationRename -> - Galley r (Maybe Public.Event) -updateUnqualifiedConversationName zusr zcon cnv rename = do - lusr <- qualifyLocal zusr - lcnv <- qualifyLocal cnv + Sem r (Maybe Public.Event) +updateUnqualifiedConversationName lusr zcon cnv rename = do + let lcnv = qualifyAs lusr cnv updateLocalConversationName lusr zcon lcnv rename updateLocalConversationName :: @@ -1466,19 +1514,20 @@ updateLocalConversationName :: Error InvalidInput, ExternalAccess, FederatorAccess, - GundeckAccess + GundeckAccess, + Input UTCTime ] r => Local UserId -> ConnId -> Local ConvId -> Public.ConversationRename -> - Galley r (Maybe Public.Event) + Sem r (Maybe Public.Event) updateLocalConversationName lusr zcon lcnv convRename = do - alive <- liftSem $ E.isConversationAlive (tUnqualified lcnv) + alive <- E.isConversationAlive (tUnqualified lcnv) if alive then updateLiveLocalConversationName lusr zcon lcnv convRename - else liftSem $ Nothing <$ E.deleteConversation (tUnqualified lcnv) + else Nothing <$ E.deleteConversation (tUnqualified lcnv) updateLiveLocalConversationName :: Members @@ -1488,50 +1537,52 @@ updateLiveLocalConversationName :: Error InvalidInput, ExternalAccess, FederatorAccess, - GundeckAccess + GundeckAccess, + Input UTCTime ] r => Local UserId -> ConnId -> Local ConvId -> Public.ConversationRename -> - Galley r (Maybe Public.Event) + Sem r (Maybe Public.Event) updateLiveLocalConversationName lusr con lcnv rename = - runMaybeT $ + fmap hush . runError @NoChanges $ updateLocalConversation lcnv (qUntagged lusr) (Just con) rename isTypingH :: Members '[ Error ConversationError, - Error InvalidInput, GundeckAccess, - MemberStore + Input (Local ()), + Input UTCTime, + MemberStore, + WaiRoutes ] r => UserId ::: ConnId ::: ConvId ::: JsonRequest Public.TypingData -> - Galley r Response + Sem r Response isTypingH (zusr ::: zcon ::: cnv ::: req) = do + lusr <- qualifyLocal zusr + lcnv <- qualifyLocal cnv typingData <- fromJsonBody req - isTyping zusr zcon cnv typingData + isTyping lusr zcon lcnv typingData pure empty isTyping :: - Members '[Error ConversationError, GundeckAccess, MemberStore] r => - UserId -> + Members '[Error ConversationError, GundeckAccess, Input UTCTime, MemberStore] r => + Local UserId -> ConnId -> - ConvId -> + Local ConvId -> Public.TypingData -> - Galley r () -isTyping zusr zcon cnv typingData = do - localDomain <- viewFederationDomain - let qcnv = Qualified cnv localDomain - qusr = Qualified zusr localDomain - mm <- liftSem $ E.getLocalMembers cnv - liftSem . unless (zusr `isMember` mm) . throw $ ConvNotFound - now <- liftIO getCurrentTime - let e = Event Typing qcnv qusr now (EdTyping typingData) - for_ (newPushLocal ListComplete zusr (ConvEvent e) (recipient <$> mm)) $ \p -> - liftSem . E.push1 $ + Sem r () +isTyping lusr zcon lcnv typingData = do + mm <- E.getLocalMembers (tUnqualified lcnv) + unless (tUnqualified lusr `isMember` mm) . throw $ ConvNotFound + now <- input + let e = Event Typing (qUntagged lcnv) (qUntagged lusr) now (EdTyping typingData) + for_ (newPushLocal ListComplete (tUnqualified lusr) (ConvEvent e) (recipient <$> mm)) $ \p -> + E.push1 $ p & pushConn ?~ zcon & pushRoute .~ RouteDirect @@ -1539,22 +1590,22 @@ isTyping zusr zcon cnv typingData = do addServiceH :: Members - '[ Error InvalidInput, - ServiceStore + '[ ServiceStore, + WaiRoutes ] r => JsonRequest Service -> - Galley r Response + Sem r Response addServiceH req = do - liftSem . E.createService =<< fromJsonBody req + E.createService =<< fromJsonBody req return empty rmServiceH :: - Members '[Error InvalidInput, ServiceStore] r => + Members '[ServiceStore, WaiRoutes] r => JsonRequest ServiceRef -> - Galley r Response + Sem r Response rmServiceH req = do - liftSem . E.deleteService =<< fromJsonBody req + E.deleteService =<< fromJsonBody req return empty addBotH :: @@ -1566,15 +1617,20 @@ addBotH :: Error ConversationError, ExternalAccess, GundeckAccess, + Input (Local ()), + Input Opts, + Input UTCTime, MemberStore, - TeamStore + TeamStore, + WaiRoutes ] r => UserId ::: ConnId ::: JsonRequest AddBot -> - Galley r Response + Sem r Response addBotH (zusr ::: zcon ::: req) = do bot <- fromJsonBody req - json <$> addBot zusr zcon bot + lusr <- qualifyLocal zusr + json <$> addBot lusr zcon bot addBot :: forall r. @@ -1586,24 +1642,25 @@ addBot :: Error InvalidInput, ExternalAccess, GundeckAccess, + Input Opts, + Input UTCTime, MemberStore, TeamStore ] r => - UserId -> + Local UserId -> ConnId -> AddBot -> - Galley r Event -addBot zusr zcon b = do - lusr <- qualifyLocal zusr + Sem r Event +addBot lusr zcon b = do c <- - liftSem $ E.getConversation (b ^. addBotConv) >>= note ConvNotFound + E.getConversation (b ^. addBotConv) >>= note ConvNotFound -- Check some preconditions on adding bots to a conversation for_ (Data.convTeam c) $ teamConvChecks (b ^. addBotConv) - (bots, users) <- regularConvChecks lusr c - t <- liftIO getCurrentTime - liftSem $ E.createClient (botUserId (b ^. addBotId)) (b ^. addBotClient) - bm <- liftSem $ E.createBotMember (b ^. addBotService) (b ^. addBotId) (b ^. addBotConv) + (bots, users) <- regularConvChecks c + t <- input + E.createClient (botUserId (b ^. addBotId)) (b ^. addBotClient) + bm <- E.createBotMember (b ^. addBotService) (b ^. addBotId) (b ^. addBotConv) let e = Event MemberJoin @@ -1618,44 +1675,46 @@ addBot zusr zcon b = do ] ) ) - for_ (newPushLocal ListComplete zusr (ConvEvent e) (recipient <$> users)) $ \p -> - liftSem . E.push1 $ p & pushConn ?~ zcon - liftSem $ E.deliverAsync ((bm : bots) `zip` repeat e) + for_ (newPushLocal ListComplete (tUnqualified lusr) (ConvEvent e) (recipient <$> users)) $ \p -> + E.push1 $ p & pushConn ?~ zcon + E.deliverAsync ((bm : bots) `zip` repeat e) pure e where - regularConvChecks lusr c = do + regularConvChecks c = do let (bots, users) = localBotsAndUsers (Data.convLocalMembers c) - liftSem . unless (zusr `isMember` users) . throw $ ConvNotFound - liftSem $ ensureGroupConversation c - self <- getSelfMemberFromLocals zusr users + unless (tUnqualified lusr `isMember` users) . throw $ ConvNotFound + ensureGroupConversation c + self <- getSelfMemberFromLocals (tUnqualified lusr) users ensureActionAllowed AddConversationMember self unless (any ((== b ^. addBotId) . botMemId) bots) $ do let botId = qualifyAs lusr (botUserId (b ^. addBotId)) ensureMemberLimit (toList $ Data.convLocalMembers c) [qUntagged botId] return (bots, users) - teamConvChecks :: ConvId -> TeamId -> Galley r () + teamConvChecks :: ConvId -> TeamId -> Sem r () teamConvChecks cid tid = do - tcv <- liftSem $ E.getTeamConversation tid cid - liftSem $ - when (maybe True (view managedConversation) tcv) $ - throw NoAddToManaged + tcv <- E.getTeamConversation tid cid + when (maybe True (view managedConversation) tcv) $ + throw NoAddToManaged rmBotH :: Members '[ ClientStore, ConversationStore, Error ConversationError, - Error InvalidInput, ExternalAccess, GundeckAccess, - MemberStore + Input (Local ()), + Input UTCTime, + MemberStore, + WaiRoutes ] r => UserId ::: Maybe ConnId ::: JsonRequest RemoveBot -> - Galley r Response + Sem r Response rmBotH (zusr ::: zcon ::: req) = do + lusr <- qualifyLocal zusr bot <- fromJsonBody req - handleUpdateResult <$> rmBot zusr zcon bot + handleUpdateResult <$> rmBot lusr zcon bot rmBot :: Members @@ -1664,30 +1723,29 @@ rmBot :: Error ConversationError, ExternalAccess, GundeckAccess, + Input UTCTime, MemberStore ] r => - UserId -> + Local UserId -> Maybe ConnId -> RemoveBot -> - Galley r (UpdateResult Event) -rmBot zusr zcon b = do + Sem r (UpdateResult Event) +rmBot lusr zcon b = do c <- - liftSem $ E.getConversation (b ^. rmBotConv) >>= note ConvNotFound - localDomain <- viewFederationDomain - let qcnv = Qualified (Data.convId c) localDomain - qusr = Qualified zusr localDomain - liftSem . unless (zusr `isMember` Data.convLocalMembers c) $ + E.getConversation (b ^. rmBotConv) >>= note ConvNotFound + let lcnv = qualifyAs lusr (Data.convId c) + unless (tUnqualified lusr `isMember` Data.convLocalMembers c) $ throw ConvNotFound let (bots, users) = localBotsAndUsers (Data.convLocalMembers c) if not (any ((== b ^. rmBotId) . botMemId) bots) then pure Unchanged else do - t <- liftIO getCurrentTime - liftSem $ do - let evd = EdMembersLeave (QualifiedUserIdList [Qualified (botUserId (b ^. rmBotId)) localDomain]) - let e = Event MemberLeave qcnv qusr t evd - for_ (newPushLocal ListComplete zusr (ConvEvent e) (recipient <$> users)) $ \p -> + t <- input + do + let evd = EdMembersLeave (QualifiedUserIdList [qUntagged (qualifyAs lusr (botUserId (b ^. rmBotId)))]) + let e = Event MemberLeave (qUntagged lcnv) (qUntagged lusr) t evd + for_ (newPushLocal ListComplete (tUnqualified lusr) (ConvEvent e) (recipient <$> users)) $ \p -> E.push1 $ p & pushConn .~ zcon E.deleteMembers (Data.convId c) (UserList [botUserId (b ^. rmBotId)] []) E.deleteClients (botUserId (b ^. rmBotId)) @@ -1697,10 +1755,9 @@ rmBot zusr zcon b = do ------------------------------------------------------------------------------- -- Helpers -ensureConvMember :: Member (Error ConversationError) r => [LocalMember] -> UserId -> Galley r () +ensureConvMember :: Member (Error ConversationError) r => [LocalMember] -> UserId -> Sem r () ensureConvMember users usr = - liftSem $ - unless (usr `isMember` users) $ throw ConvNotFound + unless (usr `isMember` users) $ throw ConvNotFound ------------------------------------------------------------------------------- -- OtrRecipients Validation @@ -1724,9 +1781,10 @@ withValidOtrBroadcastRecipients :: ClientStore, Error ActionError, Error LegalHoldError, - Error NotATeamMember, Error TeamError, - TeamStore + Input Opts, + TeamStore, + TinyLog ] r => UserId -> @@ -1734,12 +1792,12 @@ withValidOtrBroadcastRecipients :: OtrRecipients -> OtrFilterMissing -> UTCTime -> - ([(LocalMember, ClientId, Text)] -> Galley r ()) -> - Galley r OtrResult + ([(LocalMember, ClientId, Text)] -> Sem r ()) -> + Sem r OtrResult withValidOtrBroadcastRecipients usr clt rcps val now go = withBindingTeam usr $ \tid -> do - limit <- fromIntegral . fromRange <$> fanoutLimit + limit <- fromIntegral . fromRange <$> E.fanoutLimit -- If we are going to fan this out to more than limit, we want to fail early - liftSem . unless (Map.size (userClientMap (otrRecipientsMap rcps)) <= limit) $ + unless (Map.size (userClientMap (otrRecipientsMap rcps)) <= limit) $ throw BroadcastLimitExceeded -- In large teams, we may still use the broadcast endpoint but only if `report_missing` -- is used and length `report_missing` < limit since we cannot fetch larger teams than @@ -1748,14 +1806,13 @@ withValidOtrBroadcastRecipients usr clt rcps val now go = withBindingTeam usr $ fmap (view userId) <$> case val of OtrReportMissing us -> maybeFetchLimitedTeamMemberList limit tid us _ -> maybeFetchAllMembersInTeam tid - contacts <- liftSem $ E.getContactList usr + contacts <- E.getContactList usr let users = Set.toList $ Set.union (Set.fromList tMembers) (Set.fromList contacts) - isInternal <- view $ options . optSettings . setIntraListing + isInternal <- E.useIntraClientListing clts <- - liftSem $ - if isInternal - then Clients.fromUserClients <$> E.lookupClients users - else E.getClients users + if isInternal + then Clients.fromUserClients <$> E.lookupClients users + else E.getClients users let membs = newMember <$> users handleOtrResponse User usr clt rcps membs clts val now go where @@ -1764,13 +1821,13 @@ withValidOtrBroadcastRecipients usr clt rcps val now go = withBindingTeam usr $ let localUserIdsInFilter = toList uListInFilter let localUserIdsInRcps = Map.keys $ userClientMap (otrRecipientsMap rcps) let localUserIdsToLookup = Set.toList $ Set.union (Set.fromList localUserIdsInFilter) (Set.fromList localUserIdsInRcps) - liftSem . unless (length localUserIdsToLookup <= limit) $ + unless (length localUserIdsToLookup <= limit) $ throw BroadcastLimitExceeded - liftSem $ E.selectTeamMembers tid localUserIdsToLookup - maybeFetchAllMembersInTeam :: TeamId -> Galley r [TeamMember] + E.selectTeamMembers tid localUserIdsToLookup + maybeFetchAllMembersInTeam :: TeamId -> Sem r [TeamMember] maybeFetchAllMembersInTeam tid = do mems <- getTeamMembersForFanout tid - liftSem . when (mems ^. teamMemberListType == ListTruncated) $ + when (mems ^. teamMemberListType == ListTruncated) $ throw BroadcastLimitExceeded pure (mems ^. teamMembers) @@ -1780,8 +1837,10 @@ withValidOtrRecipients :: ClientStore, ConversationStore, Error LegalHoldError, + Input Opts, MemberStore, - TeamStore + TeamStore, + TinyLog ] r => UserType -> @@ -1791,27 +1850,26 @@ withValidOtrRecipients :: OtrRecipients -> OtrFilterMissing -> UTCTime -> - ([(LocalMember, ClientId, Text)] -> Galley r ()) -> - Galley r OtrResult + ([(LocalMember, ClientId, Text)] -> Sem r ()) -> + Sem r OtrResult withValidOtrRecipients utype usr clt cnv rcps val now go = do - alive <- liftSem $ E.isConversationAlive cnv + alive <- E.isConversationAlive cnv if not alive then do - liftSem $ E.deleteConversation cnv + E.deleteConversation cnv pure $ OtrConversationNotFound mkErrorDescription else do - localMembers <- liftSem $ E.getLocalMembers cnv + localMembers <- E.getLocalMembers cnv let localMemberIds = lmId <$> localMembers - isInternal <- view $ options . optSettings . setIntraListing + isInternal <- E.useIntraClientListing clts <- - liftSem $ - if isInternal - then Clients.fromUserClients <$> E.lookupClients localMemberIds - else E.getClients localMemberIds + if isInternal + then Clients.fromUserClients <$> E.lookupClients localMemberIds + else E.getClients localMemberIds handleOtrResponse utype usr clt rcps localMembers clts val now go handleOtrResponse :: - Members '[BrigAccess, Error LegalHoldError, TeamStore] r => + Members '[BrigAccess, Error LegalHoldError, Input Opts, TeamStore, TinyLog] r => -- | Type of proposed sender (user / bot) UserType -> -- | Proposed sender (user) @@ -1829,13 +1887,12 @@ handleOtrResponse :: -- | The current timestamp. UTCTime -> -- | Callback if OtrRecipients are valid - ([(LocalMember, ClientId, Text)] -> Galley r ()) -> - Galley r OtrResult + ([(LocalMember, ClientId, Text)] -> Sem r ()) -> + Sem r OtrResult handleOtrResponse utype usr clt rcps membs clts val now go = case checkOtrRecipients usr clt rcps membs clts val now of ValidOtrRecipients m r -> go r >> pure (OtrSent m) - MissingOtrRecipients m -> do + MissingOtrRecipients m -> mapError @LegalholdConflicts (const MissingLegalholdConsent) $ do guardLegalholdPolicyConflicts (userToProtectee utype usr) (missingClients m) - >>= either (const (liftSem . throw $ MissingLegalholdConsent)) pure pure (OtrMissingRecipients m) InvalidOtrSenderUser -> pure $ OtrConversationNotFound mkErrorDescription InvalidOtrSenderClient -> pure $ OtrUnknownClient mkErrorDescription @@ -1930,11 +1987,11 @@ withBindingTeam :: ] r => UserId -> - (TeamId -> Galley r b) -> - Galley r b + (TeamId -> Sem r b) -> + Sem r b withBindingTeam zusr callback = do - tid <- liftSem $ E.getOneUserTeam zusr >>= note TeamNotFound - binding <- liftSem $ E.getTeamBinding tid >>= note TeamNotFound + tid <- E.getOneUserTeam zusr >>= note TeamNotFound + binding <- E.getTeamBinding tid >>= note TeamNotFound case binding of Binding -> callback tid - NonBinding -> liftSem $ throw NotABindingTeamMember + NonBinding -> throw NotABindingTeamMember diff --git a/services/galley/src/Galley/API/Util.hs b/services/galley/src/Galley/API/Util.hs index f76e4ff748b..4971c19dc87 100644 --- a/services/galley/src/Galley/API/Util.hs +++ b/services/galley/src/Galley/API/Util.hs @@ -36,7 +36,6 @@ import Data.Qualified import qualified Data.Set as Set import Data.Time import Galley.API.Error -import Galley.App import qualified Galley.Data.Conversation as Data import Galley.Data.Services (BotMember, newBotMember) import qualified Galley.Data.Types as DataTypes @@ -64,6 +63,7 @@ import Network.Wai.Predicate hiding (Error) import qualified Network.Wai.Utilities as Wai import Polysemy import Polysemy.Error +import Polysemy.Input import qualified Wire.API.Conversation as Public import Wire.API.ErrorDescription import Wire.API.Federation.API.Galley as FederatedGalley @@ -75,8 +75,8 @@ ensureAccessRole :: Members '[BrigAccess, Error NotATeamMember, Error ConversationError] r => AccessRole -> [(UserId, Maybe TeamMember)] -> - Galley r () -ensureAccessRole role users = liftSem $ case role of + Sem r () +ensureAccessRole role users = case role of PrivateAccessRole -> throw ConvAccessDenied TeamAccessRole -> when (any (isNothing . snd) users) $ @@ -96,12 +96,12 @@ ensureConnectedOrSameTeam :: Members '[BrigAccess, TeamStore, Error ActionError] r => Local UserId -> [UserId] -> - Galley r () + Sem r () ensureConnectedOrSameTeam _ [] = pure () ensureConnectedOrSameTeam (tUnqualified -> u) uids = do - uTeams <- liftSem $ getUserTeams u + uTeams <- getUserTeams u -- We collect all the relevant uids from same teams as the origin user - sameTeamUids <- liftSem . forM uTeams $ \team -> + sameTeamUids <- forM uTeams $ \team -> fmap (view userId) <$> selectTeamMembers team uids -- Do not check connections for users that are on the same team ensureConnectedToLocals u (uids \\ join sameTeamUids) @@ -115,7 +115,7 @@ ensureConnected :: Members '[BrigAccess, Error ActionError] r => Local UserId -> UserList UserId -> - Galley r () + Sem r () ensureConnected self others = do ensureConnectedToLocals (tUnqualified self) (ulLocals others) ensureConnectedToRemotes self (ulRemotes others) @@ -124,9 +124,9 @@ ensureConnectedToLocals :: Members '[BrigAccess, Error ActionError] r => UserId -> [UserId] -> - Galley r () + Sem r () ensureConnectedToLocals _ [] = pure () -ensureConnectedToLocals u uids = liftSem $ do +ensureConnectedToLocals u uids = do (connsFrom, connsTo) <- getConnectionsUnqualifiedBidi [u] uids (Just Accepted) (Just Accepted) unless (length connsFrom == length uids && length connsTo == length uids) $ @@ -136,9 +136,9 @@ ensureConnectedToRemotes :: Members '[BrigAccess, Error ActionError] r => Local UserId -> [Remote UserId] -> - Galley r () + Sem r () ensureConnectedToRemotes _ [] = pure () -ensureConnectedToRemotes u remotes = liftSem $ do +ensureConnectedToRemotes u remotes = do acceptedConns <- getConnections [tUnqualified u] (Just $ map qUntagged remotes) (Just Accepted) when (length acceptedConns /= length remotes) $ throw NotConnected @@ -151,8 +151,8 @@ ensureReAuthorised :: r => UserId -> Maybe PlainTextPassword -> - Galley r () -ensureReAuthorised u secret = liftSem $ do + Sem r () +ensureReAuthorised u secret = do reAuthed <- reauthUser u (ReAuthUser secret) unless reAuthed $ throw ReAuthFailed @@ -164,8 +164,8 @@ ensureActionAllowed :: (IsConvMember mem, Members '[Error ActionError, Error InvalidInput] r) => Action -> mem -> - Galley r () -ensureActionAllowed action self = liftSem $ case isActionAllowed action (convMemberRole self) of + Sem r () +ensureActionAllowed action self = case isActionAllowed action (convMemberRole self) of Just True -> pure () Just False -> throw (ActionDenied action) -- Actually, this will "never" happen due to the @@ -185,8 +185,8 @@ ensureConvRoleNotElevated :: (IsConvMember mem, Members '[Error InvalidInput, Error ActionError] r) => mem -> RoleName -> - Galley r () -ensureConvRoleNotElevated origMember targetRole = liftSem $ do + Sem r () +ensureConvRoleNotElevated origMember targetRole = do case (roleNameToActions targetRole, roleNameToActions (convMemberRole origMember)) of (Just targetActions, Just memberActions) -> unless (Set.isSubsetOf targetActions memberActions) $ @@ -201,28 +201,27 @@ permissionCheck :: (IsPerm perm, Show perm, Members '[Error ActionError, Error NotATeamMember] r) => perm -> Maybe TeamMember -> - Galley r TeamMember + Sem r TeamMember permissionCheck p = - liftSem . \case + \case Just m -> do if m `hasPermission` p then pure m else throw (OperationDenied (show p)) Nothing -> throwED @NotATeamMember -assertTeamExists :: Members '[Error TeamError, TeamStore] r => TeamId -> Galley r () -assertTeamExists tid = liftSem $ do +assertTeamExists :: Members '[Error TeamError, TeamStore] r => TeamId -> Sem r () +assertTeamExists tid = do teamExists <- isJust <$> getTeam tid if teamExists then pure () else throw TeamNotFound -assertOnTeam :: Members '[Error NotATeamMember, TeamStore] r => UserId -> TeamId -> Galley r () +assertOnTeam :: Members '[Error NotATeamMember, TeamStore] r => UserId -> TeamId -> Sem r () assertOnTeam uid tid = - liftSem $ - getTeamMember tid uid >>= \case - Nothing -> throwED @NotATeamMember - Just _ -> return () + getTeamMember tid uid >>= \case + Nothing -> throwED @NotATeamMember + Just _ -> return () -- | If the conversation is in a team, throw iff zusr is a team member and does not have named -- permission. If the conversation is not in a team, do nothing (no error). @@ -238,13 +237,13 @@ permissionCheckTeamConv :: UserId -> ConvId -> Perm -> - Galley r () + Sem r () permissionCheckTeamConv zusr cnv perm = - liftSem (getConversation cnv) >>= \case + getConversation cnv >>= \case Just cnv' -> case Data.convTeam cnv' of - Just tid -> void $ permissionCheck perm =<< liftSem (getTeamMember tid zusr) + Just tid -> void $ permissionCheck perm =<< getTeamMember tid zusr Nothing -> pure () - Nothing -> liftSem $ throw ConvNotFound + Nothing -> throw ConvNotFound -- | Try to accept a 1-1 conversation, promoting connect conversations as appropriate. acceptOne2One :: @@ -253,39 +252,39 @@ acceptOne2One :: Error ActionError, Error ConversationError, Error InternalError, - MemberStore, - GundeckAccess + GundeckAccess, + Input UTCTime, + MemberStore ] r => - UserId -> + Local UserId -> Data.Conversation -> Maybe ConnId -> - Galley r Data.Conversation -acceptOne2One usr conv conn = do - lusr <- qualifyLocal usr - lcid <- qualifyLocal cid + Sem r Data.Conversation +acceptOne2One lusr conv conn = do + let lcid = qualifyAs lusr cid case Data.convType conv of One2OneConv -> - if usr `isMember` mems + if tUnqualified lusr `isMember` mems then return conv else do - mm <- liftSem $ createMember lcid lusr + mm <- createMember lcid lusr return $ conv {Data.convLocalMembers = mems <> toList mm} ConnectConv -> case mems of - [_, _] | usr `isMember` mems -> liftSem promote - [_, _] -> liftSem $ throw ConvNotFound + [_, _] | tUnqualified lusr `isMember` mems -> promote + [_, _] -> throw ConvNotFound _ -> do when (length mems > 2) $ - liftSem . throw . BadConvState $ cid - now <- liftIO getCurrentTime - mm <- liftSem $ createMember lcid lusr + throw . BadConvState $ cid + now <- input + mm <- createMember lcid lusr let e = memberJoinEvent lusr (qUntagged lcid) now mm [] - conv' <- if isJust (find ((usr /=) . lmId) mems) then liftSem promote else pure conv + conv' <- if isJust (find ((tUnqualified lusr /=) . lmId) mems) then promote else pure conv let mems' = mems <> toList mm - for_ (newPushLocal ListComplete usr (ConvEvent e) (recipient <$> mems')) $ \p -> - liftSem $ push1 $ p & pushConn .~ conn & pushRoute .~ RouteDirect + for_ (newPushLocal ListComplete (tUnqualified lusr) (ConvEvent e) (recipient <$> mems')) $ \p -> + push1 $ p & pushConn .~ conn & pushRoute .~ RouteDirect return $ conv' {Data.convLocalMembers = mems'} - x -> liftSem . throw . InvalidOp $ x + x -> throw . InvalidOp $ x where cid = Data.convId conv mems = Data.convLocalMembers conv @@ -455,9 +454,9 @@ getSelfMemberFromLocals :: (Foldable t, Member (Error ConversationError) r) => UserId -> t LocalMember -> - Galley r LocalMember + Sem r LocalMember getSelfMemberFromLocals usr lmems = - liftSem $ getMember lmId ConvNotFound usr lmems + getMember lmId ConvNotFound usr lmems -- | Throw 'ConvMemberNotFound' if the given user is not part of a -- conversation (either locally or remotely). @@ -476,9 +475,9 @@ getSelfMemberFromRemotes :: (Foldable t, Member (Error ConversationError) r) => Remote UserId -> t RemoteMember -> - Galley r RemoteMember + Sem r RemoteMember getSelfMemberFromRemotes usr rmems = - liftSem $ getMember rmId ConvNotFound usr rmems + getMember rmId ConvNotFound usr rmems getQualifiedMember :: Member (Error e) r => @@ -510,29 +509,28 @@ getMember p ex u = note ex . find ((u ==) . p) getConversationAndCheckMembership :: Members '[ConversationStore, Error ConversationError] r => UserId -> - ConvId -> - Galley r Data.Conversation -getConversationAndCheckMembership uid cnv = do + Local ConvId -> + Sem r Data.Conversation +getConversationAndCheckMembership uid lcnv = do (conv, _) <- getConversationAndMemberWithError ConvAccessDenied uid - cnv + lcnv pure conv getConversationAndMemberWithError :: (Members '[ConversationStore, Error ConversationError] r, IsConvMemberId uid mem) => ConversationError -> uid -> - ConvId -> - Galley r (Data.Conversation, mem) -getConversationAndMemberWithError ex usr convId = do - c <- liftSem $ getConversation convId >>= note ConvNotFound - liftSem . when (DataTypes.isConvDeleted c) $ do - deleteConversation convId + Local ConvId -> + Sem r (Data.Conversation, mem) +getConversationAndMemberWithError ex usr lcnv = do + c <- getConversation (tUnqualified lcnv) >>= note ConvNotFound + when (DataTypes.isConvDeleted c) $ do + deleteConversation (tUnqualified lcnv) throw ConvNotFound - loc <- qualifyLocal () - member <- liftSem . note ex $ getConvMember loc c usr + member <- note ex $ getConvMember lcnv c usr pure (c, member) -- | Deletion requires a permission check, but also a 'Role' comparison: @@ -557,35 +555,31 @@ pushConversationEvent :: (Members '[GundeckAccess, ExternalAccess] r, Foldable f) => Maybe ConnId -> Event -> - f UserId -> + Local (f UserId) -> f BotMember -> - Galley r () -pushConversationEvent conn e users bots = do - localDomain <- viewFederationDomain - for_ (newConversationEventPush localDomain e (toList users)) $ \p -> - liftSem $ push1 $ p & set pushConn conn - liftSem $ deliverAsync (toList bots `zip` repeat e) + Sem r () +pushConversationEvent conn e lusers bots = do + for_ (newConversationEventPush e (fmap toList lusers)) $ \p -> + push1 $ p & set pushConn conn + deliverAsync (toList bots `zip` repeat e) verifyReusableCode :: Members '[CodeStore, Error CodeError] r => ConversationCode -> - Galley r DataTypes.Code + Sem r DataTypes.Code verifyReusableCode convCode = do c <- - liftSem $ - getCode (conversationKey convCode) DataTypes.ReusableCode - >>= note CodeNotFound + getCode (conversationKey convCode) DataTypes.ReusableCode + >>= note CodeNotFound unless (DataTypes.codeValue c == conversationCode convCode) $ - liftSem $ throw CodeNotFound + throw CodeNotFound return c ensureConversationAccess :: Members '[ BrigAccess, ConversationStore, - Error ActionError, Error ConversationError, - Error FederationError, Error NotATeamMember, TeamStore ] @@ -593,15 +587,13 @@ ensureConversationAccess :: UserId -> ConvId -> Access -> - Galley r Data.Conversation + Sem r Data.Conversation ensureConversationAccess zusr cnv access = do conv <- - liftSem $ - getConversation cnv >>= note ConvNotFound - liftSem $ ensureAccess conv access + getConversation cnv >>= note ConvNotFound + ensureAccess conv access zusrMembership <- - liftSem $ - maybe (pure Nothing) (`getTeamMember` zusr) (Data.convTeam conv) + maybe (pure Nothing) (`getTeamMember` zusr) (Data.convTeam conv) ensureAccessRole (Data.convAccessRole conv) [(zusr, zusrMembership)] pure conv @@ -620,11 +612,14 @@ ensureLocal loc = foldQualified loc pure (\_ -> throw FederationNotImplemented) -------------------------------------------------------------------------------- -- Federation -viewFederationDomain :: MonadReader Env m => m Domain -viewFederationDomain = view (options . optSettings . setFederationDomain) +qualifyLocal :: Member (Input (Local ())) r => a -> Sem r (Local a) +qualifyLocal a = toLocalUnsafe <$> fmap getDomain input <*> pure a + where + getDomain :: Local () -> Domain + getDomain = tDomain -qualifyLocal :: MonadReader Env m => a -> m (Local a) -qualifyLocal a = toLocalUnsafe <$> viewFederationDomain <*> pure a +runLocalInput :: Local x -> Sem (Input (Local ()) ': r) a -> Sem r a +runLocalInput = runInputConst . void -- | Convert an internal conversation representation 'Data.Conversation' to -- 'NewRemoteConversation' to be sent over the wire to a remote backend that will @@ -734,8 +729,8 @@ registerRemoteConversationMemberships :: -- | The domain of the user that created the conversation Domain -> Data.Conversation -> - Galley r () -registerRemoteConversationMemberships now localDomain c = liftSem $ do + Sem r () +registerRemoteConversationMemberships now localDomain c = do let allRemoteMembers = nubOrd (map rmId (Data.convRemoteMembers c)) rc = toNewRemoteConversation now localDomain c runFederatedConcurrently_ allRemoteMembers $ \_ -> @@ -765,7 +760,7 @@ checkConsent :: Member TeamStore r => Map UserId TeamId -> UserId -> - Galley r ConsentGiven + Sem r ConsentGiven checkConsent teamsOfUsers other = do consentGiven <$> getLHStatus (Map.lookup other teamsOfUsers) other @@ -775,66 +770,75 @@ getLHStatus :: Member TeamStore r => Maybe TeamId -> UserId -> - Galley r UserLegalHoldStatus + Sem r UserLegalHoldStatus getLHStatus teamOfUser other = do case teamOfUser of Nothing -> pure defUserLegalHoldStatus Just team -> do - mMember <- liftSem $ getTeamMember team other + mMember <- getTeamMember team other pure $ maybe defUserLegalHoldStatus (view legalHoldStatus) mMember -anyLegalholdActivated :: Member TeamStore r => [UserId] -> Galley r Bool +anyLegalholdActivated :: + Members '[Input Opts, TeamStore] r => + [UserId] -> + Sem r Bool anyLegalholdActivated uids = do - view (options . optSettings . setFeatureFlags . flagLegalHold) >>= \case + opts <- input + case view (optSettings . setFeatureFlags . flagLegalHold) opts of FeatureLegalHoldDisabledPermanently -> pure False FeatureLegalHoldDisabledByDefault -> check FeatureLegalHoldWhitelistTeamsAndImplicitConsent -> check where check = do flip anyM (chunksOf 32 uids) $ \uidsPage -> do - teamsOfUsers <- liftSem $ getUsersTeams uidsPage + teamsOfUsers <- getUsersTeams uidsPage anyM (\uid -> userLHEnabled <$> getLHStatus (Map.lookup uid teamsOfUsers) uid) uidsPage allLegalholdConsentGiven :: - Members '[LegalHoldStore, TeamStore] r => + Members '[Input Opts, LegalHoldStore, TeamStore] r => [UserId] -> - Galley r Bool + Sem r Bool allLegalholdConsentGiven uids = do - view (options . optSettings . setFeatureFlags . flagLegalHold) >>= \case + opts <- input + case view (optSettings . setFeatureFlags . flagLegalHold) opts of FeatureLegalHoldDisabledPermanently -> pure False FeatureLegalHoldDisabledByDefault -> do flip allM (chunksOf 32 uids) $ \uidsPage -> do - teamsOfUsers <- liftSem $ getUsersTeams uidsPage + teamsOfUsers <- getUsersTeams uidsPage allM (\uid -> (== ConsentGiven) . consentGiven <$> getLHStatus (Map.lookup uid teamsOfUsers) uid) uidsPage FeatureLegalHoldWhitelistTeamsAndImplicitConsent -> do -- For this feature the implementation is more efficient. Being part of -- a whitelisted team is equivalent to have given consent to be in a -- conversation with user under legalhold. flip allM (chunksOf 32 uids) $ \uidsPage -> do - teamsPage <- liftSem $ nub . Map.elems <$> getUsersTeams uidsPage - allM (liftSem . isTeamLegalholdWhitelisted) teamsPage + teamsPage <- nub . Map.elems <$> getUsersTeams uidsPage + allM (isTeamLegalholdWhitelisted) teamsPage -- | Add to every uid the legalhold status getLHStatusForUsers :: Member TeamStore r => [UserId] -> - Galley r [(UserId, UserLegalHoldStatus)] + Sem r [(UserId, UserLegalHoldStatus)] getLHStatusForUsers uids = mconcat <$> ( for (chunksOf 32 uids) $ \uidsChunk -> do - teamsOfUsers <- liftSem $ getUsersTeams uidsChunk + teamsOfUsers <- getUsersTeams uidsChunk for uidsChunk $ \uid -> do (uid,) <$> getLHStatus (Map.lookup uid teamsOfUsers) uid ) -getTeamMembersForFanout :: Member TeamStore r => TeamId -> Galley r TeamMemberList +getTeamMembersForFanout :: Member TeamStore r => TeamId -> Sem r TeamMemberList getTeamMembersForFanout tid = do lim <- fanoutLimit - liftSem $ getTeamMembersWithLimit tid lim + getTeamMembersWithLimit tid lim -ensureMemberLimit :: (Foldable f, Member (Error ConversationError) r) => [LocalMember] -> f a -> Galley r () +ensureMemberLimit :: + (Foldable f, Members '[Error ConversationError, Input Opts] r) => + [LocalMember] -> + f a -> + Sem r () ensureMemberLimit old new = do - o <- view options + o <- input let maxSize = fromIntegral (o ^. optSettings . setMaxConvSize) - liftSem . when (length old + length new > maxSize) $ + when (length old + length new > maxSize) $ throw TooManyMembers diff --git a/services/galley/src/Galley/App.hs b/services/galley/src/Galley/App.hs index 3053713219c..7b63c880cbe 100644 --- a/services/galley/src/Galley/App.hs +++ b/services/galley/src/Galley/App.hs @@ -35,55 +35,35 @@ module Galley.App ExtEnv (..), extGetManager, - -- * Galley monad - Galley, + -- * Running Galley effects GalleyEffects, - Galley0, runGalley, evalGalley, ask, DeleteItem (..), toServantHandler, - - -- * Utilities - fromJsonBody, - fromOptionalJsonBody, - fromProtoBody, - fanoutLimit, - currentFanoutLimit, - - -- * Temporary compatibility functions - fireAndForget, - spawnMany, - liftGalley0, - liftSem, - unGalley, - interpretGalleyToGalley0, ) where import Bilge hiding (Request, header, options, statusCode, statusMessage) -import Bilge.RPC import Cassandra hiding (Set) import qualified Cassandra as C import qualified Cassandra.Settings as C import Control.Error import qualified Control.Exception import Control.Lens hiding ((.=)) -import Control.Monad.Catch (MonadCatch (..), MonadMask (..), MonadThrow (..)) -import Data.Aeson (FromJSON) import qualified Data.Aeson as Aeson import Data.ByteString.Conversion (toByteString') import Data.Default (def) import qualified Data.List.NonEmpty as NE import Data.Metrics.Middleware -import qualified Data.ProtocolBuffers as Proto import Data.Proxy (Proxy (..)) +import Data.Qualified import Data.Range -import Data.Serialize.Get (runGetLazy) import Data.Text (unpack) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text +import Data.Time.Clock import Galley.API.Error import qualified Galley.Aws as Aws import Galley.Cassandra.Client @@ -100,12 +80,13 @@ import Galley.Cassandra.TeamFeatures import Galley.Cassandra.TeamNotifications import Galley.Effects import Galley.Effects.FireAndForget (interpretFireAndForget) -import qualified Galley.Effects.FireAndForget as E +import Galley.Effects.WaiRoutes.IO import Galley.Env import Galley.External import Galley.Intra.Effects import Galley.Intra.Federator import Galley.Options +import Galley.Queue import qualified Galley.Queue as Q import qualified Galley.Types.Teams as Teams import Imports hiding (forkIO) @@ -115,15 +96,14 @@ import Network.HTTP.Media.RenderHeader (RenderHeader (..)) import Network.HTTP.Types (hContentType) import Network.HTTP.Types.Status (statusCode, statusMessage) import Network.Wai -import Network.Wai.Utilities hiding (Error) import qualified Network.Wai.Utilities as Wai import qualified Network.Wai.Utilities.Server as Server import OpenSSL.Session as Ssl import qualified OpenSSL.X509.SystemStore as Ssl import Polysemy import Polysemy.Error +import Polysemy.Input import Polysemy.Internal (Append) -import qualified Polysemy.Reader as P import qualified Polysemy.TinyLog as P import qualified Servant import Ssl.Util @@ -131,43 +111,12 @@ import System.Logger.Class import qualified System.Logger.Extended as Logger import qualified UnliftIO.Exception as UnliftIO import Util.Options -import Wire.API.Federation.Client (HasFederatorConfig (..)) --- MTL-style effects derived from the old implementation of the Galley monad. --- They will disappear as we introduce more high-level effects into Galley. -type GalleyEffects0 = '[P.TinyLog, P.Reader ClientState, P.Reader Env, Embed IO, Final IO] +-- Effects needed by the interpretation of other effects +type GalleyEffects0 = '[Input ClientState, Input Env, Embed IO, Final IO] type GalleyEffects = Append GalleyEffects1 GalleyEffects0 -type Galley0 = Galley GalleyEffects0 - -newtype Galley r a = Galley {unGalley :: Members GalleyEffects0 r => Sem r a} - -instance Functor (Galley r) where - fmap f (Galley x) = Galley (fmap f x) - -instance Applicative (Galley r) where - pure x = Galley (pure x) - (<*>) = ap - -instance Monad (Galley r) where - return = pure - Galley m >>= f = Galley (m >>= unGalley . f) - -instance MonadIO (Galley r) where - liftIO action = Galley (liftIO action) - -instance MonadReader Env (Galley r) where - ask = Galley $ P.ask @Env - local f m = Galley $ P.local f (unGalley m) - -instance HasFederatorConfig (Galley r) where - federatorEndpoint = view federator - federationDomain = view (options . optSettings . setFederationDomain) - -fanoutLimit :: Galley r (Range 1 Teams.HardTruncationLimit Int32) -fanoutLimit = view options >>= return . currentFanoutLimit - -- Define some invariants for the options used validateOptions :: Logger -> Opts -> IO () validateOptions l o = do @@ -191,17 +140,6 @@ validateOptions l o = do when (settings ^. setMaxTeamSize < optFanoutLimit) $ error "setMaxTeamSize cannot be < setTruncationLimit" -instance MonadLogger (Galley r) where - log l m = Galley $ P.polylog l m - -instance MonadHttp (Galley r) where - handleRequestWithCont req handler = do - httpManager <- view manager - liftIO $ withResponse req httpManager handler - -instance HasRequestId (Galley r) where - getRequestId = view reqId - createEnv :: Metrics -> Opts -> IO Env createEnv m o = do l <- Logger.mkLogger (o ^. optLogLevel) (o ^. optLogNetStrings) (o ^. optLogFormat) @@ -250,19 +188,11 @@ initHttpManager o = do managerIdleConnectionCount = 3 * (o ^. optSettings . setHttpPoolSize) } -runGalley :: Env -> Request -> Galley GalleyEffects a -> IO a +runGalley :: Env -> Request -> Sem GalleyEffects a -> IO a runGalley e r m = let e' = reqId .~ lookupReqId r $ e in evalGalley e' m -evalGalley0 :: Env -> Sem GalleyEffects0 a -> IO a -evalGalley0 e = - runFinal @IO - . embedToFinal @IO - . P.runReader e - . P.runReader (e ^. cstate) - . interpretTinyLog e - interpretTinyLog :: Members '[Embed IO] r => Env -> @@ -271,32 +201,10 @@ interpretTinyLog :: interpretTinyLog e = interpret $ \case P.Polylog l m -> Logger.log (e ^. applog) l (reqIdMsg (e ^. reqId) . m) -evalGalley :: Env -> Galley GalleyEffects a -> IO a -evalGalley e = evalGalley0 e . unGalley . interpretGalleyToGalley0 - lookupReqId :: Request -> RequestId lookupReqId = maybe def RequestId . lookup requestIdName . requestHeaders -fromJsonBody :: (Member (Error InvalidInput) r, FromJSON a) => JsonRequest a -> Galley r a -fromJsonBody r = exceptT (liftSem . throw . InvalidPayload) return (parseBody r) -{-# INLINE fromJsonBody #-} - -fromOptionalJsonBody :: - ( Member (Error InvalidInput) r, - FromJSON a - ) => - OptionalJsonRequest a -> - Galley r (Maybe a) -fromOptionalJsonBody r = exceptT (liftSem . throw . InvalidPayload) return (parseOptionalBody r) -{-# INLINE fromOptionalJsonBody #-} - -fromProtoBody :: (Member (Error InvalidInput) r, Proto.Decode a) => Request -> Galley r a -fromProtoBody r = do - b <- readBody r - either (liftSem . throw . InvalidPayload . fromString) return (runGetLazy Proto.decodeMessage b) -{-# INLINE fromProtoBody #-} - -toServantHandler :: Env -> Galley GalleyEffects a -> Servant.Handler a +toServantHandler :: Env -> Sem GalleyEffects a -> Servant.Handler a toServantHandler env galley = do eith <- liftIO $ Control.Exception.try (evalGalley env galley) case eith of @@ -313,39 +221,39 @@ toServantHandler env galley = do mkCode = statusCode . Wai.code mkPhrase = Text.unpack . Text.decodeUtf8 . statusMessage . Wai.code -withLH :: - Member (P.Reader Env) r => - (Teams.FeatureLegalHold -> Sem (eff ': r) a -> Sem r a) -> - Sem (eff ': r) a -> - Sem r a -withLH f action = do - lh <- P.asks (view (options . optSettings . setFeatureFlags . Teams.flagLegalHold)) - f lh action - interpretErrorToException :: (Exception e, Member (Embed IO) r) => Sem (Error e ': r) a -> Sem r a interpretErrorToException = (either (embed @IO . UnliftIO.throwIO) pure =<<) . runError -interpretGalleyToGalley0 :: Galley GalleyEffects a -> Galley0 a -interpretGalleyToGalley0 = - Galley +evalGalley :: Env -> Sem GalleyEffects a -> IO a +evalGalley e action = do + runFinal @IO + . embedToFinal @IO + . runInputConst e + . runInputConst (e ^. cstate) . interpretErrorToException . mapAllErrors + . interpretTinyLog e + . interpretQueue (e ^. deleteQueue) + . runInputSem (embed getCurrentTime) -- FUTUREWORK: could we take the time only once instead? + . interpretWaiRoutes + . runInputConst (e ^. options) + . runInputConst (toLocalUnsafe (e ^. options . optSettings . setFederationDomain) ()) . interpretInternalTeamListToCassandra . interpretTeamListToCassandra . interpretLegacyConversationListToCassandra . interpretRemoteConversationListToCassandra . interpretConversationListToCassandra - . withLH interpretTeamMemberStoreToCassandra - . withLH interpretTeamStoreToCassandra + . interpretTeamMemberStoreToCassandra lh + . interpretTeamStoreToCassandra lh . interpretTeamNotificationStoreToCassandra . interpretTeamFeatureStoreToCassandra . interpretServiceStoreToCassandra . interpretSearchVisibilityStoreToCassandra . interpretMemberStoreToCassandra - . withLH interpretLegalHoldStoreToCassandra + . interpretLegalHoldStoreToCassandra lh . interpretCustomBackendStoreToCassandra . interpretConversationStoreToCassandra . interpretCodeStoreToCassandra @@ -354,44 +262,9 @@ interpretGalleyToGalley0 = . interpretBotAccess . interpretFederatorAccess . interpretExternalAccess - . interpretSparAccess . interpretGundeckAccess + . interpretSparAccess . interpretBrigAccess - . unGalley - ----------------------------------------------------------------------------------- ----- temporary MonadUnliftIO support code for the polysemy refactoring - -fireAndForget :: Member FireAndForget r => Galley r () -> Galley r () -fireAndForget (Galley m) = Galley $ E.fireAndForget m - -spawnMany :: Member FireAndForget r => [Galley r ()] -> Galley r () -spawnMany ms = Galley $ E.spawnMany (map unGalley ms) - -instance MonadUnliftIO Galley0 where - askUnliftIO = Galley $ do - env <- P.ask @Env - pure $ UnliftIO $ evalGalley0 env . unGalley - -instance MonadMask Galley0 where - mask = UnliftIO.mask - uninterruptibleMask = UnliftIO.uninterruptibleMask - generalBracket acquire release useB = Galley $ do - env <- P.ask @Env - embed @IO $ - generalBracket - (evalGalley0 env (unGalley acquire)) - (\resource exitCase -> evalGalley0 env (unGalley (release resource exitCase))) - (\resource -> evalGalley0 env (unGalley (useB resource))) - -instance MonadThrow Galley0 where - throwM e = Galley (embed @IO (throwM e)) - -instance MonadCatch Galley0 where - catch = UnliftIO.catch - -liftGalley0 :: Galley0 a -> Galley r a -liftGalley0 (Galley m) = Galley $ subsume_ m - -liftSem :: Sem r a -> Galley r a -liftSem m = Galley m + $ action + where + lh = view (options . optSettings . setFeatureFlags . Teams.flagLegalHold) e diff --git a/services/galley/src/Galley/Cassandra/Client.hs b/services/galley/src/Galley/Cassandra/Client.hs index ee0f4e3bda2..f5432f2a927 100644 --- a/services/galley/src/Galley/Cassandra/Client.hs +++ b/services/galley/src/Galley/Cassandra/Client.hs @@ -23,16 +23,20 @@ where import Cassandra import Control.Arrow +import Control.Lens import Data.Id import Data.List.Split (chunksOf) import qualified Galley.Cassandra.Queries as Cql import Galley.Cassandra.Store import Galley.Effects.ClientStore (ClientStore (..)) +import Galley.Env +import Galley.Monad +import Galley.Options import Galley.Types.Clients (Clients) import qualified Galley.Types.Clients as Clients import Imports import Polysemy -import qualified Polysemy.Reader as P +import Polysemy.Input import qualified UnliftIO updateClient :: Bool -> UserId -> ClientId -> Client () @@ -54,7 +58,7 @@ eraseClients :: UserId -> Client () eraseClients user = retry x5 (write Cql.rmClients (params LocalQuorum (Identity user))) interpretClientStoreToCassandra :: - Members '[Embed IO, P.Reader ClientState] r => + Members '[Embed IO, Input ClientState, Input Env] r => Sem (ClientStore ': r) a -> Sem r a interpretClientStoreToCassandra = interpret $ \case @@ -62,3 +66,4 @@ interpretClientStoreToCassandra = interpret $ \case CreateClient uid cid -> embedClient $ updateClient True uid cid DeleteClient uid cid -> embedClient $ updateClient False uid cid DeleteClients uid -> embedClient $ eraseClients uid + UseIntraClientListing -> embedApp . view $ options . optSettings . setIntraListing diff --git a/services/galley/src/Galley/Cassandra/Code.hs b/services/galley/src/Galley/Cassandra/Code.hs index 539c2aaa4ec..b2d41aaf028 100644 --- a/services/galley/src/Galley/Cassandra/Code.hs +++ b/services/galley/src/Galley/Cassandra/Code.hs @@ -22,17 +22,20 @@ where import Brig.Types.Code import Cassandra +import Control.Lens import qualified Galley.Cassandra.Queries as Cql import Galley.Cassandra.Store import Galley.Data.Types import qualified Galley.Data.Types as Code import Galley.Effects.CodeStore (CodeStore (..)) +import Galley.Env +import Galley.Options import Imports import Polysemy -import qualified Polysemy.Reader as P +import Polysemy.Input interpretCodeStoreToCassandra :: - Members '[Embed IO, P.Reader ClientState] r => + Members '[Embed IO, Input ClientState, Input Env] r => Sem (CodeStore ': r) a -> Sem r a interpretCodeStoreToCassandra = interpret $ \case @@ -41,6 +44,8 @@ interpretCodeStoreToCassandra = interpret $ \case DeleteCode k s -> embedClient $ deleteCode k s MakeKey cid -> Code.mkKey cid GenerateCode cid s t -> Code.generate cid s t + GetConversationCodeURI -> + view (options . optSettings . setConversationCodeURI) <$> input -- | Insert a conversation code insertCode :: Code -> Client () diff --git a/services/galley/src/Galley/Cassandra/Conversation.hs b/services/galley/src/Galley/Cassandra/Conversation.hs index 04822d1850c..bf394171954 100644 --- a/services/galley/src/Galley/Cassandra/Conversation.hs +++ b/services/galley/src/Galley/Cassandra/Conversation.hs @@ -44,7 +44,7 @@ import Galley.Types.UserList import Galley.Validation import Imports import Polysemy -import qualified Polysemy.Reader as P +import Polysemy.Input import Polysemy.TinyLog import qualified System.Logger as Log import qualified UnliftIO @@ -281,7 +281,7 @@ conversationGC conv = case join (convDeleted <$> conv) of _ -> return conv localConversations :: - (Members '[Embed IO, P.Reader ClientState, TinyLog] r) => + (Members '[Embed IO, Input ClientState, TinyLog] r) => [ConvId] -> Sem r [Conversation] localConversations [] = return [] @@ -345,7 +345,7 @@ toConv cid mms remoteMems conv = f ms (cty, uid, acc, role, nme, ti, del, timer, rm) = Conversation cid cty uid nme (defAccess cty acc) (maybeRole cty role) ms remoteMems ti del timer rm interpretConversationStoreToCassandra :: - Members '[Embed IO, P.Reader ClientState, TinyLog] r => + Members '[Embed IO, Input ClientState, TinyLog] r => Sem (ConversationStore ': r) a -> Sem r a interpretConversationStoreToCassandra = interpret $ \case diff --git a/services/galley/src/Galley/Cassandra/Conversation/Members.hs b/services/galley/src/Galley/Cassandra/Conversation/Members.hs index 039fc643428..7e5e86ed596 100644 --- a/services/galley/src/Galley/Cassandra/Conversation/Members.hs +++ b/services/galley/src/Galley/Cassandra/Conversation/Members.hs @@ -44,9 +44,9 @@ import Galley.Types.ToUserRole import Galley.Types.UserList import Imports import Polysemy -import qualified Polysemy.Reader as P +import Polysemy.Input import qualified UnliftIO -import Wire.API.Conversation.Member +import Wire.API.Conversation.Member hiding (Member) import Wire.API.Conversation.Role import Wire.API.Provider.Service @@ -340,7 +340,7 @@ removeLocalMembersFromRemoteConv (qUntagged -> Qualified conv convDomain) victim for_ victims $ \u -> addPrepQuery Cql.deleteUserRemoteConv (u, convDomain, conv) interpretMemberStoreToCassandra :: - Members '[Embed IO, P.Reader ClientState] r => + Members '[Embed IO, Input ClientState] r => Sem (MemberStore ': r) a -> Sem r a interpretMemberStoreToCassandra = interpret $ \case diff --git a/services/galley/src/Galley/Cassandra/ConversationList.hs b/services/galley/src/Galley/Cassandra/ConversationList.hs index 324b7fad34e..a183e209b92 100644 --- a/services/galley/src/Galley/Cassandra/ConversationList.hs +++ b/services/galley/src/Galley/Cassandra/ConversationList.hs @@ -34,7 +34,7 @@ import Galley.Cassandra.Store import Galley.Effects.ListItems import Imports hiding (max) import Polysemy -import qualified Polysemy.Reader as P +import Polysemy.Input -- | Deprecated, use 'localConversationIdsPageFrom' conversationIdsFrom :: @@ -66,21 +66,21 @@ remoteConversationIdsPageFrom usr pagingState max = uncurry toRemoteUnsafe <$$> paginateWithState Cql.selectUserRemoteConvs (paramsPagingState LocalQuorum (Identity usr) max pagingState) interpretConversationListToCassandra :: - Members '[Embed IO, P.Reader ClientState] r => + Members '[Embed IO, Input ClientState] r => Sem (ListItems CassandraPaging ConvId ': r) a -> Sem r a interpretConversationListToCassandra = interpret $ \case ListItems uid ps max -> embedClient $ localConversationIdsPageFrom uid ps max interpretRemoteConversationListToCassandra :: - Members '[Embed IO, P.Reader ClientState] r => + Members '[Embed IO, Input ClientState] r => Sem (ListItems CassandraPaging (Remote ConvId) ': r) a -> Sem r a interpretRemoteConversationListToCassandra = interpret $ \case ListItems uid ps max -> embedClient $ remoteConversationIdsPageFrom uid ps (fromRange max) interpretLegacyConversationListToCassandra :: - Members '[Embed IO, P.Reader ClientState] r => + Members '[Embed IO, Input ClientState] r => Sem (ListItems LegacyPaging ConvId ': r) a -> Sem r a interpretLegacyConversationListToCassandra = interpret $ \case diff --git a/services/galley/src/Galley/Cassandra/CustomBackend.hs b/services/galley/src/Galley/Cassandra/CustomBackend.hs index fe757271b82..da687a9cac3 100644 --- a/services/galley/src/Galley/Cassandra/CustomBackend.hs +++ b/services/galley/src/Galley/Cassandra/CustomBackend.hs @@ -28,10 +28,10 @@ import Galley.Effects.CustomBackendStore (CustomBackendStore (..)) import Galley.Types import Imports import Polysemy -import qualified Polysemy.Reader as P +import Polysemy.Input interpretCustomBackendStoreToCassandra :: - Members '[Embed IO, P.Reader ClientState] r => + Members '[Embed IO, Input ClientState] r => Sem (CustomBackendStore ': r) a -> Sem r a interpretCustomBackendStoreToCassandra = interpret $ \case diff --git a/services/galley/src/Galley/Cassandra/LegalHold.hs b/services/galley/src/Galley/Cassandra/LegalHold.hs index 87345d5c79e..aa96b12559b 100644 --- a/services/galley/src/Galley/Cassandra/LegalHold.hs +++ b/services/galley/src/Galley/Cassandra/LegalHold.hs @@ -21,6 +21,7 @@ module Galley.Cassandra.LegalHold -- * Used by tests selectPendingPrekeys, + validateServiceKey, ) where @@ -28,20 +29,33 @@ import Brig.Types.Client.Prekey import Brig.Types.Instances () import Brig.Types.Team.LegalHold import Cassandra +import Control.Exception.Enclosed (handleAny) import Control.Lens (unsnoc) +import Data.ByteString.Conversion.To +import qualified Data.ByteString.Lazy.Char8 as LC8 import Data.Id import Data.LegalHold +import Data.Misc import Galley.Cassandra.Instances () import qualified Galley.Cassandra.Queries as Q import Galley.Cassandra.Store import Galley.Effects.LegalHoldStore (LegalHoldStore (..)) +import Galley.Env +import Galley.External.LegalHoldService.Internal +import Galley.Monad import Galley.Types.Teams import Imports +import qualified OpenSSL.EVP.Digest as SSL +import qualified OpenSSL.EVP.PKey as SSL +import qualified OpenSSL.PEM as SSL +import qualified OpenSSL.RSA as SSL import Polysemy -import qualified Polysemy.Reader as P +import Polysemy.Input +import qualified Ssl.Util as SSL +import Wire.API.Provider.Service interpretLegalHoldStoreToCassandra :: - Members '[Embed IO, P.Reader ClientState] r => + Members '[Embed IO, Input ClientState, Input Env] r => FeatureLegalHold -> Sem (LegalHoldStore ': r) a -> Sem r a @@ -56,6 +70,12 @@ interpretLegalHoldStoreToCassandra lh = interpret $ \case SetTeamLegalholdWhitelisted tid -> embedClient $ setTeamLegalholdWhitelisted tid UnsetTeamLegalholdWhitelisted tid -> embedClient $ unsetTeamLegalholdWhitelisted tid IsTeamLegalholdWhitelisted tid -> embedClient $ isTeamLegalholdWhitelisted lh tid + -- FUTUREWORK: should this action be part of a separate effect? + MakeVerifiedRequestFreshManager fpr url r -> + embedApp $ makeVerifiedRequestFreshManager fpr url r + MakeVerifiedRequest fpr url r -> + embedApp $ makeVerifiedRequest fpr url r + ValidateServiceKey sk -> embed @IO $ validateServiceKey sk -- | Returns 'False' if legal hold is not enabled for this team -- The Caller is responsible for checking whether legal hold is enabled for this team @@ -114,3 +134,33 @@ isTeamLegalholdWhitelisted FeatureLegalHoldDisabledPermanently _ = pure False isTeamLegalholdWhitelisted FeatureLegalHoldDisabledByDefault _ = pure False isTeamLegalholdWhitelisted FeatureLegalHoldWhitelistTeamsAndImplicitConsent tid = isJust <$> (runIdentity <$$> retry x5 (query1 Q.selectLegalHoldWhitelistedTeam (params LocalQuorum (Identity tid)))) + +-- | Copied unchanged from "Brig.Provider.API". Interpret a service certificate and extract +-- key and fingerprint. (This only has to be in 'MonadIO' because the FFI in OpenSSL works +-- like that.) +-- +-- FUTUREWORK: It would be nice to move (part of) this to ssl-util, but it has types from +-- brig-types and types-common. +validateServiceKey :: MonadIO m => ServiceKeyPEM -> m (Maybe (ServiceKey, Fingerprint Rsa)) +validateServiceKey pem = + liftIO $ + readPublicKey >>= \pk -> + case join (SSL.toPublicKey <$> pk) of + Nothing -> return Nothing + Just pk' -> do + Just sha <- SSL.getDigestByName "SHA256" + let size = SSL.rsaSize (pk' :: SSL.RSAPubKey) + if size < minRsaKeySize + then return Nothing + else do + fpr <- Fingerprint <$> SSL.rsaFingerprint sha pk' + let bits = fromIntegral size * 8 + let key = ServiceKey RsaServiceKey bits pem + return $ Just (key, fpr) + where + readPublicKey = + handleAny + (const $ return Nothing) + (SSL.readPublicKey (LC8.unpack (toByteString pem)) >>= return . Just) + minRsaKeySize :: Int + minRsaKeySize = 256 -- Bytes (= 2048 bits) diff --git a/services/galley/src/Galley/Cassandra/SearchVisibility.hs b/services/galley/src/Galley/Cassandra/SearchVisibility.hs index cd3905ad4ce..136ac414c0d 100644 --- a/services/galley/src/Galley/Cassandra/SearchVisibility.hs +++ b/services/galley/src/Galley/Cassandra/SearchVisibility.hs @@ -26,10 +26,10 @@ import Galley.Effects.SearchVisibilityStore (SearchVisibilityStore (..)) import Galley.Types.Teams.SearchVisibility import Imports import Polysemy -import qualified Polysemy.Reader as P +import Polysemy.Input interpretSearchVisibilityStoreToCassandra :: - Members '[Embed IO, P.Reader ClientState] r => + Members '[Embed IO, Input ClientState] r => Sem (SearchVisibilityStore ': r) a -> Sem r a interpretSearchVisibilityStoreToCassandra = interpret $ \case diff --git a/services/galley/src/Galley/Cassandra/Services.hs b/services/galley/src/Galley/Cassandra/Services.hs index 724c5dab5f5..785502a988f 100644 --- a/services/galley/src/Galley/Cassandra/Services.hs +++ b/services/galley/src/Galley/Cassandra/Services.hs @@ -29,7 +29,7 @@ import Galley.Types.Bot import Galley.Types.Conversations.Members (newMember) import Imports import Polysemy -import qualified Polysemy.Reader as P +import Polysemy.Input -- FUTUREWORK: support adding bots to a remote conversation addBotMember :: ServiceRef -> BotId -> ConvId -> Client BotMember @@ -48,7 +48,7 @@ addBotMember s bot cnv = do -- Service -------------------------------------------------------------------- interpretServiceStoreToCassandra :: - Members '[Embed IO, P.Reader ClientState] r => + Members '[Embed IO, Input ClientState] r => Sem (ServiceStore ': r) a -> Sem r a interpretServiceStoreToCassandra = interpret $ \case diff --git a/services/galley/src/Galley/Cassandra/Store.hs b/services/galley/src/Galley/Cassandra/Store.hs index d610321fcc0..07a876e02aa 100644 --- a/services/galley/src/Galley/Cassandra/Store.hs +++ b/services/galley/src/Galley/Cassandra/Store.hs @@ -23,9 +23,9 @@ where import Cassandra import Imports import Polysemy -import Polysemy.Reader as P +import Polysemy.Input -embedClient :: Members '[Embed IO, P.Reader ClientState] r => Client a -> Sem r a +embedClient :: Members '[Embed IO, Input ClientState] r => Client a -> Sem r a embedClient client = do - cs <- P.ask + cs <- input embed @IO $ runClient cs client diff --git a/services/galley/src/Galley/Cassandra/Team.hs b/services/galley/src/Galley/Cassandra/Team.hs index 9e5ece8d008..7d0f373a290 100644 --- a/services/galley/src/Galley/Cassandra/Team.hs +++ b/services/galley/src/Galley/Cassandra/Team.hs @@ -36,6 +36,7 @@ import qualified Data.Map.Strict as Map import Data.Range import qualified Data.Set as Set import Data.UUID.V4 (nextRandom) +import qualified Galley.Aws as Aws import qualified Galley.Cassandra.Conversation as C import Galley.Cassandra.LegalHold (isTeamLegalholdWhitelisted) import Galley.Cassandra.Paging @@ -45,6 +46,9 @@ import Galley.Cassandra.Store import Galley.Effects.ListItems import Galley.Effects.TeamMemberStore import Galley.Effects.TeamStore (TeamStore (..)) +import Galley.Env +import Galley.Monad +import Galley.Options import Galley.Types.Teams hiding ( DeleteTeam, GetTeamConversations, @@ -54,12 +58,12 @@ import qualified Galley.Types.Teams as Teams import Galley.Types.Teams.Intra import Imports hiding (Set, max) import Polysemy -import qualified Polysemy.Reader as P +import Polysemy.Input import qualified UnliftIO import Wire.API.Team.Member interpretTeamStoreToCassandra :: - Members '[Embed IO, P.Reader ClientState] r => + Members '[Embed IO, Input Env, Input ClientState] r => FeatureLegalHold -> Sem (TeamStore ': r) a -> Sem r a @@ -89,16 +93,23 @@ interpretTeamStoreToCassandra lh = interpret $ \case DeleteTeamConversation tid cid -> embedClient $ removeTeamConv tid cid SetTeamData tid upd -> embedClient $ updateTeam tid upd SetTeamStatus tid st -> embedClient $ updateTeamStatus tid st + FanoutLimit -> embedApp $ currentFanoutLimit <$> view options + GetLegalHoldFlag -> + view (options . optSettings . setFeatureFlags . flagLegalHold) <$> input + EnqueueTeamEvent e -> do + menv <- inputs (view aEnv) + for_ menv $ \env -> + embed @IO $ Aws.execute env (Aws.enqueue e) interpretTeamListToCassandra :: - Members '[Embed IO, P.Reader ClientState] r => + Members '[Embed IO, Input ClientState] r => Sem (ListItems LegacyPaging TeamId ': r) a -> Sem r a interpretTeamListToCassandra = interpret $ \case ListItems uid ps lim -> embedClient $ teamIdsFrom uid ps lim interpretInternalTeamListToCassandra :: - Members '[Embed IO, P.Reader ClientState] r => + Members '[Embed IO, Input ClientState] r => Sem (ListItems InternalPaging TeamId ': r) a -> Sem r a interpretInternalTeamListToCassandra = interpret $ \case @@ -109,7 +120,7 @@ interpretInternalTeamListToCassandra = interpret $ \case Just ps -> ipNext ps interpretTeamMemberStoreToCassandra :: - Members '[Embed IO, P.Reader ClientState] r => + Members '[Embed IO, Input ClientState] r => FeatureLegalHold -> Sem (TeamMemberStore InternalPaging ': r) a -> Sem r a diff --git a/services/galley/src/Galley/Cassandra/TeamFeatures.hs b/services/galley/src/Galley/Cassandra/TeamFeatures.hs index 7ef181c87af..e723fe47689 100644 --- a/services/galley/src/Galley/Cassandra/TeamFeatures.hs +++ b/services/galley/src/Galley/Cassandra/TeamFeatures.hs @@ -26,7 +26,7 @@ import Galley.Data.TeamFeatures import Galley.Effects.TeamFeatureStore (TeamFeatureStore (..)) import Imports import Polysemy -import qualified Polysemy.Reader as P +import Polysemy.Input import Wire.API.Team.Feature getFeatureStatusNoConfig :: @@ -141,7 +141,7 @@ setSelfDeletingMessagesStatus tid status = do <> "values (?, ?, ?)" interpretTeamFeatureStoreToCassandra :: - Members '[Embed IO, P.Reader ClientState] r => + Members '[Embed IO, Input ClientState] r => Sem (TeamFeatureStore ': r) a -> Sem r a interpretTeamFeatureStoreToCassandra = interpret $ \case diff --git a/services/galley/src/Galley/Cassandra/TeamNotifications.hs b/services/galley/src/Galley/Cassandra/TeamNotifications.hs index 2a12e347371..dc0cb800c78 100644 --- a/services/galley/src/Galley/Cassandra/TeamNotifications.hs +++ b/services/galley/src/Galley/Cassandra/TeamNotifications.hs @@ -27,27 +27,44 @@ module Galley.Cassandra.TeamNotifications where import Cassandra +import Control.Monad.Catch +import Control.Retry (exponentialBackoff, limitRetries, retrying) import qualified Data.Aeson as JSON import Data.Id import Data.List1 (List1) import Data.Range (Range, fromRange) import Data.Sequence (Seq, ViewL (..), ViewR (..), (<|), (><)) import qualified Data.Sequence as Seq +import qualified Data.UUID.V1 as UUID import Galley.Cassandra.Store import Galley.Data.TeamNotifications -import Galley.Effects.TeamNotificationStore +import Galley.Effects +import Galley.Effects.TeamNotificationStore (TeamNotificationStore (..)) import Gundeck.Types.Notification import Imports +import Network.HTTP.Types +import Network.Wai.Utilities hiding (Error) import Polysemy -import qualified Polysemy.Reader as P +import Polysemy.Input interpretTeamNotificationStoreToCassandra :: - Members '[Embed IO, P.Reader ClientState] r => + Members '[Embed IO, Input ClientState] r => Sem (TeamNotificationStore ': r) a -> Sem r a interpretTeamNotificationStoreToCassandra = interpret $ \case CreateTeamNotification tid nid objs -> embedClient $ add tid nid objs GetTeamNotifications tid mnid lim -> embedClient $ fetch tid mnid lim + MkNotificationId -> embed mkNotificationId + +-- | 'Data.UUID.V1.nextUUID' is sometimes unsuccessful, so we try a few times. +mkNotificationId :: IO NotificationId +mkNotificationId = do + ni <- fmap Id <$> retrying x10 fun (const (liftIO UUID.nextUUID)) + maybe (throwM err) return ni + where + x10 = limitRetries 10 <> exponentialBackoff 10 + fun = const (return . isNothing) + err = mkError status500 "internal-error" "unable to generate notification ID" -- FUTUREWORK: the magic 32 should be made configurable, so it can be tuned add :: diff --git a/services/galley/src/Galley/Effects.hs b/services/galley/src/Galley/Effects.hs index f56cde0885b..68912c86c94 100644 --- a/services/galley/src/Galley/Effects.hs +++ b/services/galley/src/Galley/Effects.hs @@ -49,6 +49,10 @@ module Galley.Effects -- * Paging effects ListItems, + -- * Other effects + Queue, + WaiRoutes, + -- * Polysemy re-exports Member, Members, @@ -57,6 +61,7 @@ where import Data.Id import Data.Qualified +import Data.Time.Clock import Galley.API.Error import Galley.Cassandra.Paging import Galley.Effects.BotAccess @@ -72,6 +77,7 @@ import Galley.Effects.GundeckAccess import Galley.Effects.LegalHoldStore import Galley.Effects.ListItems import Galley.Effects.MemberStore +import Galley.Effects.Queue import Galley.Effects.SearchVisibilityStore import Galley.Effects.ServiceStore import Galley.Effects.SparAccess @@ -79,15 +85,20 @@ import Galley.Effects.TeamFeatureStore import Galley.Effects.TeamMemberStore import Galley.Effects.TeamNotificationStore import Galley.Effects.TeamStore +import Galley.Effects.WaiRoutes +import Galley.Env +import Galley.Options import qualified Network.Wai.Utilities as Wai import Polysemy import Polysemy.Error +import Polysemy.Input import Polysemy.Internal +import Polysemy.TinyLog type NonErrorGalleyEffects1 = '[ BrigAccess, - GundeckAccess, SparAccess, + GundeckAccess, ExternalAccess, FederatorAccess, BotAccess, @@ -108,7 +119,13 @@ type NonErrorGalleyEffects1 = ListItems CassandraPaging (Remote ConvId), ListItems LegacyPaging ConvId, ListItems LegacyPaging TeamId, - ListItems InternalPaging TeamId + ListItems InternalPaging TeamId, + Input (Local ()), + Input Opts, + WaiRoutes, + Input UTCTime, + Queue DeleteItem, + TinyLog ] -- All the possible high-level effects. diff --git a/services/galley/src/Galley/Effects/BrigAccess.hs b/services/galley/src/Galley/Effects/BrigAccess.hs index 5741e3b8b15..7ff6b448b00 100644 --- a/services/galley/src/Galley/Effects/BrigAccess.hs +++ b/services/galley/src/Galley/Effects/BrigAccess.hs @@ -44,6 +44,9 @@ module Galley.Effects.BrigAccess getLegalHoldAuthToken, addLegalHoldClientToUser, removeLegalHoldClientFromUser, + + -- * Features + getAccountFeatureConfigClient, ) where @@ -59,6 +62,7 @@ import Imports import Network.HTTP.Types.Status import Polysemy import Wire.API.Routes.Internal.Brig.Connection +import Wire.API.Team.Feature import Wire.API.Team.Size import Wire.API.User.Client import Wire.API.User.RichInfo @@ -106,6 +110,7 @@ data BrigAccess m a where LastPrekey -> BrigAccess m ClientId RemoveLegalHoldClientFromUser :: UserId -> BrigAccess m () + GetAccountFeatureConfigClient :: UserId -> BrigAccess m TeamFeatureStatusNoConfig makeSem ''BrigAccess diff --git a/services/galley/src/Galley/Effects/ClientStore.hs b/services/galley/src/Galley/Effects/ClientStore.hs index 451716d66a5..26250ba3a4b 100644 --- a/services/galley/src/Galley/Effects/ClientStore.hs +++ b/services/galley/src/Galley/Effects/ClientStore.hs @@ -28,11 +28,15 @@ module Galley.Effects.ClientStore -- * Delete client deleteClient, deleteClients, + + -- * Configuration + useIntraClientListing, ) where import Data.Id import Galley.Types.Clients +import Imports import Polysemy data ClientStore m a where @@ -40,5 +44,6 @@ data ClientStore m a where CreateClient :: UserId -> ClientId -> ClientStore m () DeleteClient :: UserId -> ClientId -> ClientStore m () DeleteClients :: UserId -> ClientStore m () + UseIntraClientListing :: ClientStore m Bool makeSem ''ClientStore diff --git a/services/galley/src/Galley/Effects/CodeStore.hs b/services/galley/src/Galley/Effects/CodeStore.hs index d06105ce5f4..0920da520a7 100644 --- a/services/galley/src/Galley/Effects/CodeStore.hs +++ b/services/galley/src/Galley/Effects/CodeStore.hs @@ -31,11 +31,15 @@ module Galley.Effects.CodeStore -- * Code generation makeKey, generateCode, + + -- * Configuration + getConversationCodeURI, ) where import Brig.Types.Code import Data.Id +import Data.Misc import Galley.Data.Types import Imports import Polysemy @@ -46,5 +50,6 @@ data CodeStore m a where DeleteCode :: Key -> Scope -> CodeStore m () MakeKey :: ConvId -> CodeStore m Key GenerateCode :: ConvId -> Scope -> Timeout -> CodeStore m Code + GetConversationCodeURI :: CodeStore m HttpsUrl makeSem ''CodeStore diff --git a/services/galley/src/Galley/Effects/FederatorAccess.hs b/services/galley/src/Galley/Effects/FederatorAccess.hs index 9a31cd3e097..9aa1db8c315 100644 --- a/services/galley/src/Galley/Effects/FederatorAccess.hs +++ b/services/galley/src/Galley/Effects/FederatorAccess.hs @@ -21,7 +21,9 @@ module Galley.Effects.FederatorAccess runFederated, runFederatedEither, runFederatedConcurrently, + runFederatedConcurrentlyEither, runFederatedConcurrently_, + isFederationConfigured, ) where @@ -49,6 +51,13 @@ data FederatorAccess m a where f (Remote x) -> (Remote [x] -> FederatedRPC c a) -> FederatorAccess m [Remote a] + RunFederatedConcurrentlyEither :: + forall (c :: Component) f a m x. + (Foldable f, Functor f) => + f (Remote x) -> + (Remote [x] -> FederatedRPC c a) -> + FederatorAccess m [Either (Remote [x], FederationError) (Remote a)] + IsFederationConfigured :: FederatorAccess m Bool makeSem ''FederatorAccess diff --git a/services/galley/src/Galley/Effects/GundeckAccess.hs b/services/galley/src/Galley/Effects/GundeckAccess.hs index 1f035ff1a87..93308d6e635 100644 --- a/services/galley/src/Galley/Effects/GundeckAccess.hs +++ b/services/galley/src/Galley/Effects/GundeckAccess.hs @@ -20,6 +20,7 @@ module Galley.Effects.GundeckAccess GundeckAccess (..), push, push1, + pushSlowly, ) where @@ -29,6 +30,7 @@ import Polysemy data GundeckAccess m a where Push :: Foldable f => f G.Push -> GundeckAccess m () + PushSlowly :: Foldable f => f G.Push -> GundeckAccess m () makeSem ''GundeckAccess diff --git a/services/galley/src/Galley/Effects/LegalHoldStore.hs b/services/galley/src/Galley/Effects/LegalHoldStore.hs index 28b70fcf1f8..4dab3fbefb7 100644 --- a/services/galley/src/Galley/Effects/LegalHoldStore.hs +++ b/services/galley/src/Galley/Effects/LegalHoldStore.hs @@ -16,7 +16,10 @@ -- with this program. If not, see . module Galley.Effects.LegalHoldStore - ( LegalHoldStore (..), + ( -- * LegalHold store effect + LegalHoldStore (..), + + -- * Store actions createSettings, getSettings, removeSettings, @@ -27,14 +30,23 @@ module Galley.Effects.LegalHoldStore setTeamLegalholdWhitelisted, unsetTeamLegalholdWhitelisted, isTeamLegalholdWhitelisted, + validateServiceKey, + + -- * Intra actions + makeVerifiedRequest, + makeVerifiedRequestFreshManager, ) where +import qualified Data.ByteString.Lazy.Char8 as LC8 import Data.Id import Data.LegalHold +import Data.Misc import Galley.External.LegalHoldService.Types import Imports +import qualified Network.HTTP.Client as Http import Polysemy +import Wire.API.Provider.Service import Wire.API.User.Client.Prekey data LegalHoldStore m a where @@ -48,5 +60,17 @@ data LegalHoldStore m a where SetTeamLegalholdWhitelisted :: TeamId -> LegalHoldStore m () UnsetTeamLegalholdWhitelisted :: TeamId -> LegalHoldStore m () IsTeamLegalholdWhitelisted :: TeamId -> LegalHoldStore m Bool + -- intra actions + MakeVerifiedRequestFreshManager :: + Fingerprint Rsa -> + HttpsUrl -> + (Http.Request -> Http.Request) -> + LegalHoldStore m (Http.Response LC8.ByteString) + MakeVerifiedRequest :: + Fingerprint Rsa -> + HttpsUrl -> + (Http.Request -> Http.Request) -> + LegalHoldStore m (Http.Response LC8.ByteString) + ValidateServiceKey :: ServiceKeyPEM -> LegalHoldStore m (Maybe (ServiceKey, Fingerprint Rsa)) makeSem ''LegalHoldStore diff --git a/services/galley/src/Galley/Effects/Queue.hs b/services/galley/src/Galley/Effects/Queue.hs new file mode 100644 index 00000000000..111ab6d2946 --- /dev/null +++ b/services/galley/src/Galley/Effects/Queue.hs @@ -0,0 +1,32 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- 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 . + +module Galley.Effects.Queue + ( Queue (..), + tryPush, + pop, + ) +where + +import Imports +import Polysemy + +data Queue a m x where + TryPush :: a -> Queue a m Bool + Pop :: Queue a m a + +makeSem ''Queue diff --git a/services/galley/src/Galley/Effects/TeamNotificationStore.hs b/services/galley/src/Galley/Effects/TeamNotificationStore.hs index 5e553315d44..23f4d7ed846 100644 --- a/services/galley/src/Galley/Effects/TeamNotificationStore.hs +++ b/services/galley/src/Galley/Effects/TeamNotificationStore.hs @@ -15,7 +15,13 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.Effects.TeamNotificationStore where +module Galley.Effects.TeamNotificationStore + ( TeamNotificationStore (..), + createTeamNotification, + getTeamNotifications, + mkNotificationId, + ) +where import qualified Data.Aeson as JSON import Data.Id @@ -37,5 +43,6 @@ data TeamNotificationStore m a where Maybe NotificationId -> Range 1 10000 Int32 -> TeamNotificationStore m ResultPage + MkNotificationId :: TeamNotificationStore m NotificationId makeSem ''TeamNotificationStore diff --git a/services/galley/src/Galley/Effects/TeamStore.hs b/services/galley/src/Galley/Effects/TeamStore.hs index 541d87f39dc..18eee5f98ca 100644 --- a/services/galley/src/Galley/Effects/TeamStore.hs +++ b/services/galley/src/Galley/Effects/TeamStore.hs @@ -63,6 +63,13 @@ module Galley.Effects.TeamStore -- ** Delete team members deleteTeamMember, + + -- * Configuration + fanoutLimit, + getLegalHoldFlag, + + -- * Events + enqueueTeamEvent, ) where @@ -74,6 +81,7 @@ import Galley.Types.Teams import Galley.Types.Teams.Intra import Imports import Polysemy +import qualified Proto.TeamEvents as E data TeamStore m a where CreateTeamMember :: TeamId -> TeamMember -> TeamStore m () @@ -107,6 +115,9 @@ data TeamStore m a where DeleteTeamConversation :: TeamId -> ConvId -> TeamStore m () SetTeamData :: TeamId -> TeamUpdateData -> TeamStore m () SetTeamStatus :: TeamId -> TeamStatus -> TeamStore m () + FanoutLimit :: TeamStore m (Range 1 HardTruncationLimit Int32) + GetLegalHoldFlag :: TeamStore m FeatureLegalHold + EnqueueTeamEvent :: E.TeamEvent -> TeamStore m () makeSem ''TeamStore diff --git a/services/galley/src/Galley/Effects/WaiRoutes.hs b/services/galley/src/Galley/Effects/WaiRoutes.hs new file mode 100644 index 00000000000..3e3a43a5389 --- /dev/null +++ b/services/galley/src/Galley/Effects/WaiRoutes.hs @@ -0,0 +1,38 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- 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 . + +module Galley.Effects.WaiRoutes + ( WaiRoutes (..), + fromJsonBody, + fromOptionalJsonBody, + fromProtoBody, + ) +where + +import Data.Aeson (FromJSON) +import qualified Data.ProtocolBuffers as Proto +import Imports +import Network.Wai +import Network.Wai.Utilities hiding (Error) +import Polysemy + +data WaiRoutes m a where + FromJsonBody :: FromJSON a => JsonRequest a -> WaiRoutes m a + FromOptionalJsonBody :: FromJSON a => OptionalJsonRequest a -> WaiRoutes m (Maybe a) + FromProtoBody :: Proto.Decode a => Request -> WaiRoutes m a + +makeSem ''WaiRoutes diff --git a/services/galley/src/Galley/Effects/WaiRoutes/IO.hs b/services/galley/src/Galley/Effects/WaiRoutes/IO.hs new file mode 100644 index 00000000000..a71aba6080b --- /dev/null +++ b/services/galley/src/Galley/Effects/WaiRoutes/IO.hs @@ -0,0 +1,39 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- 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 . + +module Galley.Effects.WaiRoutes.IO where + +import Control.Error +import qualified Data.ProtocolBuffers as Proto +import Data.Serialize.Get +import Galley.API.Error +import Galley.Effects.WaiRoutes +import Imports +import Network.Wai.Utilities hiding (Error) +import Polysemy +import Polysemy.Error + +interpretWaiRoutes :: + Members '[Embed IO, Error InvalidInput] r => + Sem (WaiRoutes ': r) a -> + Sem r a +interpretWaiRoutes = interpret $ \case + FromJsonBody r -> exceptT (throw . InvalidPayload) return (parseBody r) + FromOptionalJsonBody r -> exceptT (throw . InvalidPayload) return (parseOptionalBody r) + FromProtoBody r -> do + b <- readBody r + either (throw . InvalidPayload . fromString) return (runGetLazy Proto.decodeMessage b) diff --git a/services/galley/src/Galley/External.hs b/services/galley/src/Galley/External.hs index e325f3da587..d25d3db1900 100644 --- a/services/galley/src/Galley/External.hs +++ b/services/galley/src/Galley/External.hs @@ -30,7 +30,7 @@ import Galley.Effects import Galley.Effects.ExternalAccess (ExternalAccess (..)) import Galley.Env import Galley.Intra.User -import Galley.Intra.Util +import Galley.Monad import Galley.Types (Event) import Galley.Types.Bot import Imports @@ -38,7 +38,7 @@ import qualified Network.HTTP.Client as Http import Network.HTTP.Types.Method import Network.HTTP.Types.Status (status410) import Polysemy -import qualified Polysemy.Reader as P +import Polysemy.Input import Ssl.Util (withVerifiedSslConnection) import qualified System.Logger.Class as Log import System.Logger.Message (field, msg, val, (~~)) @@ -46,37 +46,37 @@ import URI.ByteString import UnliftIO (Async, async, waitCatch) interpretExternalAccess :: - Members '[Embed IO, P.Reader Env] r => + Members '[Embed IO, Input Env] r => Sem (ExternalAccess ': r) a -> Sem r a interpretExternalAccess = interpret $ \case - Deliver pp -> embedIntra $ deliver (toList pp) - DeliverAsync pp -> embedIntra $ deliverAsync (toList pp) - DeliverAndDeleteAsync cid pp -> embedIntra $ deliverAndDeleteAsync cid (toList pp) + Deliver pp -> embedApp $ deliver (toList pp) + DeliverAsync pp -> embedApp $ deliverAsync (toList pp) + DeliverAndDeleteAsync cid pp -> embedApp $ deliverAndDeleteAsync cid (toList pp) -- | Like deliver, but ignore orphaned bots and return immediately. -- -- FUTUREWORK: Check if this can be removed. -deliverAsync :: [(BotMember, Event)] -> IntraM () +deliverAsync :: [(BotMember, Event)] -> App () deliverAsync = void . forkIO . void . deliver -- | Like deliver, but remove orphaned bots and return immediately. -deliverAndDeleteAsync :: ConvId -> [(BotMember, Event)] -> IntraM () +deliverAndDeleteAsync :: ConvId -> [(BotMember, Event)] -> App () deliverAndDeleteAsync cnv pushes = void . forkIO $ do gone <- deliver pushes mapM_ (deleteBot cnv . botMemId) gone -deliver :: [(BotMember, Event)] -> IntraM [BotMember] +deliver :: [(BotMember, Event)] -> App [BotMember] deliver pp = mapM (async . exec) pp >>= foldM eval [] . zip (map fst pp) where - exec :: (BotMember, Event) -> IntraM Bool + exec :: (BotMember, Event) -> App Bool exec (b, e) = lookupService (botMemService b) >>= \case Nothing -> return False Just s -> do deliver1 s b e return True - eval :: [BotMember] -> (BotMember, Async Bool) -> IntraM [BotMember] + eval :: [BotMember] -> (BotMember, Async Bool) -> App [BotMember] eval gone (b, a) = do let s = botMemService b r <- waitCatch a @@ -115,7 +115,7 @@ deliver pp = mapM (async . exec) pp >>= foldM eval [] . zip (map fst pp) -- Internal ------------------------------------------------------------------- -deliver1 :: Service -> BotMember -> Event -> IntraM () +deliver1 :: Service -> BotMember -> Event -> App () deliver1 s bm e | s ^. serviceEnabled = do let t = toByteString' (s ^. serviceToken) @@ -145,7 +145,7 @@ urlPort (HttpsUrl u) = do p <- a ^. authorityPortL return (fromIntegral (p ^. portNumberL)) -sendMessage :: [Fingerprint Rsa] -> (Request -> Request) -> IntraM () +sendMessage :: [Fingerprint Rsa] -> (Request -> Request) -> App () sendMessage fprs reqBuilder = do (man, verifyFingerprints) <- view (extEnv . extGetManager) liftIO . withVerifiedSslConnection (verifyFingerprints fprs) man reqBuilder $ \req -> diff --git a/services/galley/src/Galley/External/LegalHoldService.hs b/services/galley/src/Galley/External/LegalHoldService.hs index affafacf2ee..14dee18e6ac 100644 --- a/services/galley/src/Galley/External/LegalHoldService.hs +++ b/services/galley/src/Galley/External/LegalHoldService.hs @@ -29,55 +29,40 @@ where import qualified Bilge import Bilge.Response -import Bilge.Retry import Brig.Types.Provider import Brig.Types.Team.LegalHold -import Control.Exception.Enclosed (handleAny) -import Control.Lens hiding ((#), (.=)) -import Control.Monad.Catch -import Control.Retry import Data.Aeson -import qualified Data.ByteString as BS import Data.ByteString.Conversion.To import qualified Data.ByteString.Lazy.Char8 as LC8 import Data.Id import Data.Misc import Galley.API.Error -import Galley.App import Galley.Effects.LegalHoldStore as LegalHoldData -import Galley.Env import Galley.External.LegalHoldService.Types import Imports import qualified Network.HTTP.Client as Http import Network.HTTP.Types -import qualified OpenSSL.EVP.Digest as SSL -import qualified OpenSSL.EVP.PKey as SSL -import qualified OpenSSL.PEM as SSL -import qualified OpenSSL.RSA as SSL -import qualified OpenSSL.Session as SSL import Polysemy import Polysemy.Error -import Ssl.Util -import qualified Ssl.Util as SSL +import qualified Polysemy.TinyLog as P import qualified System.Logger.Class as Log -import URI.ByteString (uriPath) ---------------------------------------------------------------------- -- api -- | Get /status from legal hold service; throw 'Wai.Error' if things go wrong. checkLegalHoldServiceStatus :: - Member (Error LegalHoldError) r => + Members '[Error LegalHoldError, LegalHoldStore, P.TinyLog] r => Fingerprint Rsa -> HttpsUrl -> - Galley r () + Sem r () checkLegalHoldServiceStatus fpr url = do resp <- makeVerifiedRequestFreshManager fpr url reqBuilder if | Bilge.statusCode resp < 400 -> pure () | otherwise -> do - Log.info . Log.msg $ showResponse resp - liftSem $ throw LegalHoldServiceBadResponse + P.info . Log.msg $ showResponse resp + throw LegalHoldServiceBadResponse where reqBuilder :: Http.Request -> Http.Request reqBuilder = @@ -87,16 +72,16 @@ checkLegalHoldServiceStatus fpr url = do -- | @POST /initiate@. requestNewDevice :: - Members '[Error LegalHoldError, LegalHoldStore] r => + Members '[Error LegalHoldError, LegalHoldStore, P.TinyLog] r => TeamId -> UserId -> - Galley r NewLegalHoldClient + Sem r NewLegalHoldClient requestNewDevice tid uid = do resp <- makeLegalHoldServiceRequest tid reqParams case eitherDecode (responseBody resp) of Left e -> do - Log.info . Log.msg $ "Error decoding NewLegalHoldClient: " <> e - liftSem $ throw LegalHoldServiceBadResponse + P.info . Log.msg $ "Error decoding NewLegalHoldClient: " <> e + throw LegalHoldServiceBadResponse Right client -> pure client where reqParams = @@ -115,7 +100,7 @@ confirmLegalHold :: UserId -> -- | TODO: Replace with 'LegalHold' token type OpaqueAuthToken -> - Galley r () + Sem r () confirmLegalHold clientId tid uid legalHoldAuthToken = do void $ makeLegalHoldServiceRequest tid reqParams where @@ -132,7 +117,7 @@ removeLegalHold :: Members '[Error LegalHoldError, LegalHoldStore] r => TeamId -> UserId -> - Galley r () + Sem r () removeLegalHold tid uid = do void $ makeLegalHoldServiceRequest tid reqParams where @@ -153,11 +138,11 @@ makeLegalHoldServiceRequest :: Members '[Error LegalHoldError, LegalHoldStore] r => TeamId -> (Http.Request -> Http.Request) -> - Galley r (Http.Response LC8.ByteString) + Sem r (Http.Response LC8.ByteString) makeLegalHoldServiceRequest tid reqBuilder = do - maybeLHSettings <- liftSem $ LegalHoldData.getSettings tid + maybeLHSettings <- LegalHoldData.getSettings tid lhSettings <- case maybeLHSettings of - Nothing -> liftSem $ throw LegalHoldServiceNotRegistered + Nothing -> throw LegalHoldServiceNotRegistered Just lhSettings -> pure lhSettings let LegalHoldService { legalHoldServiceUrl = baseUrl, @@ -169,84 +154,3 @@ makeLegalHoldServiceRequest tid reqBuilder = do mkReqBuilder token = reqBuilder . Bilge.header "Authorization" ("Bearer " <> toByteString' token) - -makeVerifiedRequest :: Fingerprint Rsa -> HttpsUrl -> (Http.Request -> Http.Request) -> Galley r (Http.Response LC8.ByteString) -makeVerifiedRequest fpr url reqBuilder = do - (mgr, verifyFingerprints) <- view (extEnv . extGetManager) - makeVerifiedRequestWithManager mgr verifyFingerprints fpr url reqBuilder - --- | NOTE: Use this function wisely - this creates a new manager _every_ time it is called. --- We should really _only_ use it in `checkLegalHoldServiceStatus` for the time being because --- this is where we check for signatures, etc. If we reuse the manager, we are likely to reuse --- an existing connection which will _not_ cause the new public key to be verified. -makeVerifiedRequestFreshManager :: Fingerprint Rsa -> HttpsUrl -> (Http.Request -> Http.Request) -> Galley r (Http.Response LC8.ByteString) -makeVerifiedRequestFreshManager fpr url reqBuilder = do - ExtEnv (mgr, verifyFingerprints) <- liftIO initExtEnv - makeVerifiedRequestWithManager mgr verifyFingerprints fpr url reqBuilder - --- | Check that the given fingerprint is valid and make the request over ssl. --- If the team has a device registered use 'makeLegalHoldServiceRequest' instead. -makeVerifiedRequestWithManager :: Http.Manager -> ([Fingerprint Rsa] -> SSL.SSL -> IO ()) -> Fingerprint Rsa -> HttpsUrl -> (Http.Request -> Http.Request) -> Galley r (Http.Response LC8.ByteString) -makeVerifiedRequestWithManager mgr verifyFingerprints fpr (HttpsUrl url) reqBuilder = do - let verified = verifyFingerprints [fpr] - liftGalley0 $ - extHandleAll errHandler $ do - recovering x3 httpHandlers $ - const $ - liftIO $ - withVerifiedSslConnection verified mgr (reqBuilderMods . reqBuilder) $ - \req -> - Http.httpLbs req mgr - where - reqBuilderMods = - maybe id Bilge.host (Bilge.extHost url) - . Bilge.port (fromMaybe 443 (Bilge.extPort url)) - . Bilge.secure - . prependPath (uriPath url) - errHandler e = do - Log.info . Log.msg $ "error making request to legalhold service: " <> show e - throwM legalHoldServiceUnavailable - prependPath :: ByteString -> Http.Request -> Http.Request - prependPath pth req = req {Http.path = pth Http.path req} - -- append two paths with exactly one slash - () :: ByteString -> ByteString -> ByteString - a b = fromMaybe a (BS.stripSuffix "/" a) <> "/" <> fromMaybe b (BS.stripPrefix "/" b) - x3 :: RetryPolicy - x3 = limitRetries 3 <> exponentialBackoff 100000 - extHandleAll :: MonadCatch m => (SomeException -> m a) -> m a -> m a - extHandleAll f ma = - catches - ma - [ Handler $ \(ex :: SomeAsyncException) -> throwM ex, - Handler $ \(ex :: SomeException) -> f ex - ] - --- | Copied unchanged from "Brig.Provider.API". Interpret a service certificate and extract --- key and fingerprint. (This only has to be in 'MonadIO' because the FFI in OpenSSL works --- like that.) --- --- FUTUREWORK: It would be nice to move (part of) this to ssl-util, but it has types from --- brig-types and types-common. -validateServiceKey :: MonadIO m => ServiceKeyPEM -> m (Maybe (ServiceKey, Fingerprint Rsa)) -validateServiceKey pem = - liftIO $ - readPublicKey >>= \pk -> - case join (SSL.toPublicKey <$> pk) of - Nothing -> return Nothing - Just pk' -> do - Just sha <- SSL.getDigestByName "SHA256" - let size = SSL.rsaSize (pk' :: SSL.RSAPubKey) - if size < minRsaKeySize - then return Nothing - else do - fpr <- Fingerprint <$> SSL.rsaFingerprint sha pk' - let bits = fromIntegral size * 8 - let key = ServiceKey RsaServiceKey bits pem - return $ Just (key, fpr) - where - readPublicKey = - handleAny - (const $ return Nothing) - (SSL.readPublicKey (LC8.unpack (toByteString pem)) >>= return . Just) - minRsaKeySize :: Int - minRsaKeySize = 256 -- Bytes (= 2048 bits) diff --git a/services/galley/src/Galley/External/LegalHoldService/Internal.hs b/services/galley/src/Galley/External/LegalHoldService/Internal.hs new file mode 100644 index 00000000000..47836150ad4 --- /dev/null +++ b/services/galley/src/Galley/External/LegalHoldService/Internal.hs @@ -0,0 +1,99 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- 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 . + +module Galley.External.LegalHoldService.Internal + ( makeVerifiedRequest, + makeVerifiedRequestFreshManager, + ) +where + +import qualified Bilge +import Bilge.Retry +import Brig.Types.Provider +import Control.Lens (view) +import Control.Monad.Catch +import Control.Retry +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy.Char8 as LC8 +import Data.Misc +import Galley.API.Error +import Galley.Env +import Galley.Monad +import Imports +import qualified Network.HTTP.Client as Http +import qualified OpenSSL.Session as SSL +import Ssl.Util +import qualified System.Logger.Class as Log +import URI.ByteString (uriPath) + +-- | Check that the given fingerprint is valid and make the request over ssl. +-- If the team has a device registered use 'makeLegalHoldServiceRequest' instead. +makeVerifiedRequestWithManager :: Http.Manager -> ([Fingerprint Rsa] -> SSL.SSL -> IO ()) -> Fingerprint Rsa -> HttpsUrl -> (Http.Request -> Http.Request) -> App (Http.Response LC8.ByteString) +makeVerifiedRequestWithManager mgr verifyFingerprints fpr (HttpsUrl url) reqBuilder = do + let verified = verifyFingerprints [fpr] + extHandleAll errHandler $ do + recovering x3 httpHandlers $ + const $ + liftIO $ + withVerifiedSslConnection verified mgr (reqBuilderMods . reqBuilder) $ + \req -> + Http.httpLbs req mgr + where + reqBuilderMods = + maybe id Bilge.host (Bilge.extHost url) + . Bilge.port (fromMaybe 443 (Bilge.extPort url)) + . Bilge.secure + . prependPath (uriPath url) + errHandler e = do + Log.info . Log.msg $ "error making request to legalhold service: " <> show e + throwM legalHoldServiceUnavailable + prependPath :: ByteString -> Http.Request -> Http.Request + prependPath pth req = req {Http.path = pth Http.path req} + -- append two paths with exactly one slash + () :: ByteString -> ByteString -> ByteString + a b = fromMaybe a (BS.stripSuffix "/" a) <> "/" <> fromMaybe b (BS.stripPrefix "/" b) + x3 :: RetryPolicy + x3 = limitRetries 3 <> exponentialBackoff 100000 + extHandleAll :: MonadCatch m => (SomeException -> m a) -> m a -> m a + extHandleAll f ma = + catches + ma + [ Handler $ \(ex :: SomeAsyncException) -> throwM ex, + Handler $ \(ex :: SomeException) -> f ex + ] + +makeVerifiedRequest :: + Fingerprint Rsa -> + HttpsUrl -> + (Http.Request -> Http.Request) -> + App (Http.Response LC8.ByteString) +makeVerifiedRequest fpr url reqBuilder = do + (mgr, verifyFingerprints) <- view (extEnv . extGetManager) + makeVerifiedRequestWithManager mgr verifyFingerprints fpr url reqBuilder + +-- | NOTE: Use this function wisely - this creates a new manager _every_ time it is called. +-- We should really _only_ use it in `checkLegalHoldServiceStatus` for the time being because +-- this is where we check for signatures, etc. If we reuse the manager, we are likely to reuse +-- an existing connection which will _not_ cause the new public key to be verified. +makeVerifiedRequestFreshManager :: + Fingerprint Rsa -> + HttpsUrl -> + (Http.Request -> Http.Request) -> + App (Http.Response LC8.ByteString) +makeVerifiedRequestFreshManager fpr url reqBuilder = do + ExtEnv (mgr, verifyFingerprints) <- liftIO initExtEnv + makeVerifiedRequestWithManager mgr verifyFingerprints fpr url reqBuilder diff --git a/services/galley/src/Galley/Intra/Client.hs b/services/galley/src/Galley/Intra/Client.hs index 52a783513c7..59587ed99c7 100644 --- a/services/galley/src/Galley/Intra/Client.hs +++ b/services/galley/src/Galley/Intra/Client.hs @@ -31,7 +31,6 @@ import Brig.Types.Client import Brig.Types.Intra import Brig.Types.Team.LegalHold (LegalHoldClientRequest (..)) import Brig.Types.User.Auth (LegalHoldLogin (..)) -import Control.Monad.Catch import Data.ByteString.Conversion (toByteString') import Data.Id import Data.Misc @@ -42,18 +41,20 @@ import Galley.Effects import Galley.Env import Galley.External.LegalHoldService.Types import Galley.Intra.Util +import Galley.Monad import Imports import Network.HTTP.Types.Method import Network.HTTP.Types.Status -import Network.Wai.Utilities.Error +import Network.Wai.Utilities.Error hiding (Error) import Polysemy -import qualified Polysemy.Reader as P +import Polysemy.Error +import Polysemy.Input import qualified Polysemy.TinyLog as P import qualified System.Logger.Class as Logger import Wire.API.User.Client (UserClients, UserClientsFull, filterClients, filterClientsFull) -- | Calls 'Brig.API.internalListClientsH'. -lookupClients :: [UserId] -> IntraM UserClients +lookupClients :: [UserId] -> App UserClients lookupClients uids = do r <- call Brig $ @@ -67,7 +68,7 @@ lookupClients uids = do -- | Calls 'Brig.API.internalListClientsFullH'. lookupClientsFull :: [UserId] -> - IntraM UserClientsFull + App UserClientsFull lookupClientsFull uids = do r <- call Brig $ @@ -83,7 +84,7 @@ notifyClientsAboutLegalHoldRequest :: UserId -> UserId -> LastPrekey -> - IntraM () + App () notifyClientsAboutLegalHoldRequest requesterUid targetUid lastPrekey' = do void . call Brig $ method POST @@ -93,13 +94,13 @@ notifyClientsAboutLegalHoldRequest requesterUid targetUid lastPrekey' = do -- | Calls 'Brig.User.API.Auth.legalHoldLoginH'. getLegalHoldAuthToken :: - Members '[Embed IO, P.TinyLog, P.Reader Env] r => + Members '[Embed IO, Error InternalError, P.TinyLog, Input Env] r => UserId -> Maybe PlainTextPassword -> Sem r OpaqueAuthToken getLegalHoldAuthToken uid pw = do r <- - embedIntra . call Brig $ + embedApp . call Brig $ method POST . path "/i/legalhold-login" . queryItem "persist" "true" @@ -108,7 +109,7 @@ getLegalHoldAuthToken uid pw = do case getCookieValue "zuid" r of Nothing -> do P.warn $ Logger.msg @Text "Response from login missing auth cookie" - embed $ throwM internalError + throw $ InternalErrorWithDescription "internal error" Just c -> pure . OpaqueAuthToken . decodeUtf8 $ c -- | Calls 'Brig.API.addClientInternalH'. @@ -117,7 +118,7 @@ addLegalHoldClientToUser :: ConnId -> [Prekey] -> LastPrekey -> - IntraM ClientId + App ClientId addLegalHoldClientToUser uid connId prekeys lastPrekey' = do clientId <$> brigAddClient uid connId lhClient where @@ -136,7 +137,7 @@ addLegalHoldClientToUser uid connId prekeys lastPrekey' = do -- | Calls 'Brig.API.removeLegalHoldClientH'. removeLegalHoldClientFromUser :: UserId -> - IntraM () + App () removeLegalHoldClientFromUser targetUid = do void . call Brig $ method DELETE @@ -145,7 +146,7 @@ removeLegalHoldClientFromUser targetUid = do . expect2xx -- | Calls 'Brig.API.addClientInternalH'. -brigAddClient :: UserId -> ConnId -> NewClient -> IntraM Client +brigAddClient :: UserId -> ConnId -> NewClient -> App Client brigAddClient uid connId client = do r <- call Brig $ diff --git a/services/galley/src/Galley/Intra/Effects.hs b/services/galley/src/Galley/Intra/Effects.hs index 26191832bfa..a282b00d04d 100644 --- a/services/galley/src/Galley/Intra/Effects.hs +++ b/services/galley/src/Galley/Intra/Effects.hs @@ -23,6 +23,7 @@ module Galley.Intra.Effects ) where +import Galley.API.Error import Galley.Effects.BotAccess (BotAccess (..)) import Galley.Effects.BrigAccess (BrigAccess (..)) import Galley.Effects.GundeckAccess (GundeckAccess (..)) @@ -33,63 +34,67 @@ import qualified Galley.Intra.Push.Internal as G import Galley.Intra.Spar import Galley.Intra.Team import Galley.Intra.User -import Galley.Intra.Util +import Galley.Monad import Imports import Polysemy -import qualified Polysemy.Reader as P +import Polysemy.Error +import Polysemy.Input import qualified Polysemy.TinyLog as P import qualified UnliftIO interpretBrigAccess :: - Members '[Embed IO, P.TinyLog, P.Reader Env] r => + Members '[Embed IO, Error InternalError, P.TinyLog, Input Env] r => Sem (BrigAccess ': r) a -> Sem r a interpretBrigAccess = interpret $ \case GetConnectionsUnqualified uids muids mrel -> - embedIntra $ getConnectionsUnqualified uids muids mrel + embedApp $ getConnectionsUnqualified uids muids mrel GetConnectionsUnqualifiedBidi uids1 uids2 mrel1 mrel2 -> - embedIntra $ + embedApp $ UnliftIO.concurrently (getConnectionsUnqualified uids1 (Just uids2) mrel1) (getConnectionsUnqualified uids2 (Just uids1) mrel2) GetConnections uids mquids mrel -> - embedIntra $ + embedApp $ getConnections uids mquids mrel - PutConnectionInternal uc -> embedIntra $ putConnectionInternal uc - ReauthUser uid reauth -> embedIntra $ reAuthUser uid reauth - LookupActivatedUsers uids -> embedIntra $ lookupActivatedUsers uids - GetUsers uids -> embedIntra $ getUsers uids - DeleteUser uid -> embedIntra $ deleteUser uid - GetContactList uid -> embedIntra $ getContactList uid - GetRichInfoMultiUser uids -> embedIntra $ getRichInfoMultiUser uids - GetSize tid -> embedIntra $ getSize tid - LookupClients uids -> embedIntra $ lookupClients uids - LookupClientsFull uids -> embedIntra $ lookupClientsFull uids + PutConnectionInternal uc -> embedApp $ putConnectionInternal uc + ReauthUser uid reauth -> embedApp $ reAuthUser uid reauth + LookupActivatedUsers uids -> embedApp $ lookupActivatedUsers uids + GetUsers uids -> embedApp $ getUsers uids + DeleteUser uid -> embedApp $ deleteUser uid + GetContactList uid -> embedApp $ getContactList uid + GetRichInfoMultiUser uids -> embedApp $ getRichInfoMultiUser uids + GetSize tid -> embedApp $ getSize tid + LookupClients uids -> embedApp $ lookupClients uids + LookupClientsFull uids -> embedApp $ lookupClientsFull uids NotifyClientsAboutLegalHoldRequest self other pk -> - embedIntra $ notifyClientsAboutLegalHoldRequest self other pk + embedApp $ notifyClientsAboutLegalHoldRequest self other pk GetLegalHoldAuthToken uid mpwd -> getLegalHoldAuthToken uid mpwd AddLegalHoldClientToUser uid conn pks lpk -> - embedIntra $ addLegalHoldClientToUser uid conn pks lpk + embedApp $ addLegalHoldClientToUser uid conn pks lpk RemoveLegalHoldClientFromUser uid -> - embedIntra $ removeLegalHoldClientFromUser uid + embedApp $ removeLegalHoldClientFromUser uid + GetAccountFeatureConfigClient uid -> + embedApp $ getAccountFeatureConfigClient uid interpretSparAccess :: - Members '[Embed IO, P.Reader Env] r => + Members '[Embed IO, Input Env] r => Sem (SparAccess ': r) a -> Sem r a interpretSparAccess = interpret $ \case - DeleteTeam tid -> embedIntra $ deleteTeam tid + DeleteTeam tid -> embedApp $ deleteTeam tid interpretBotAccess :: - Members '[Embed IO, P.Reader Env] r => + Members '[Embed IO, Input Env] r => Sem (BotAccess ': r) a -> Sem r a interpretBotAccess = interpret $ \case - DeleteBot cid bid -> embedIntra $ deleteBot cid bid + DeleteBot cid bid -> embedApp $ deleteBot cid bid interpretGundeckAccess :: - Members '[Embed IO, P.TinyLog, P.Reader Env] r => + Members '[Embed IO, Input Env] r => Sem (GundeckAccess ': r) a -> Sem r a interpretGundeckAccess = interpret $ \case - Push ps -> embedIntra $ G.push ps + Push ps -> embedApp $ G.push ps + PushSlowly ps -> embedApp $ G.pushSlowly ps diff --git a/services/galley/src/Galley/Intra/Federator.hs b/services/galley/src/Galley/Intra/Federator.hs index cd08fb32572..b4bf53c6c26 100644 --- a/services/galley/src/Galley/Intra/Federator.hs +++ b/services/galley/src/Galley/Intra/Federator.hs @@ -20,46 +20,44 @@ module Galley.Intra.Federator (interpretFederatorAccess) where import Control.Monad.Except +import Data.Bifunctor import Data.Qualified import Galley.Effects.FederatorAccess (FederatorAccess (..)) import Galley.Env import Galley.Intra.Federator.Types +import Galley.Monad import Imports import Polysemy -import qualified Polysemy.Reader as P +import Polysemy.Input import UnliftIO import Wire.API.Federation.Client import Wire.API.Federation.Error -embedFederationM :: - Members '[Embed IO, P.Reader Env] r => - FederationM a -> - Sem r a -embedFederationM action = do - env <- P.ask - embed $ runFederationM env action - interpretFederatorAccess :: - Members '[Embed IO, P.Reader Env] r => + Members '[Embed IO, Input Env] r => Sem (FederatorAccess ': r) a -> Sem r a interpretFederatorAccess = interpret $ \case - RunFederated dom rpc -> embedFederationM $ runFederated dom rpc - RunFederatedEither dom rpc -> embedFederationM $ runFederatedEither dom rpc - RunFederatedConcurrently rs f -> embedFederationM $ runFederatedConcurrently rs f + RunFederated dom rpc -> embedApp $ runFederated dom rpc + RunFederatedEither dom rpc -> embedApp $ runFederatedEither dom rpc + RunFederatedConcurrently rs f -> embedApp $ runFederatedConcurrently rs f + RunFederatedConcurrentlyEither rs f -> + embedApp $ + runFederatedConcurrentlyEither rs f + IsFederationConfigured -> embedApp $ isJust <$> federatorEndpoint runFederatedEither :: Remote x -> FederatedRPC c a -> - FederationM (Either FederationError a) + App (Either FederationError a) runFederatedEither (tDomain -> remoteDomain) rpc = do env <- ask - liftIO $ runFederationM env (runExceptT (executeFederated remoteDomain rpc)) + liftIO $ runApp env (runExceptT (executeFederated remoteDomain rpc)) runFederated :: Remote x -> FederatedRPC c a -> - FederationM a + App a runFederated dom rpc = runFederatedEither dom rpc >>= either (throwIO . federationErrorToWai) pure @@ -68,7 +66,16 @@ runFederatedConcurrently :: (Foldable f, Functor f) => f (Remote a) -> (Remote [a] -> FederatedRPC c b) -> - FederationM [Remote b] + App [Remote b] runFederatedConcurrently xs rpc = pooledForConcurrentlyN 8 (bucketRemote xs) $ \r -> qualifyAs r <$> runFederated r (rpc r) + +runFederatedConcurrentlyEither :: + (Foldable f, Functor f) => + f (Remote a) -> + (Remote [a] -> FederatedRPC c b) -> + App [Either (Remote [a], FederationError) (Remote b)] +runFederatedConcurrentlyEither xs rpc = + pooledForConcurrentlyN 8 (bucketRemote xs) $ \r -> + bimap (r,) (qualifyAs r) <$> runFederatedEither r (rpc r) diff --git a/services/galley/src/Galley/Intra/Federator/Types.hs b/services/galley/src/Galley/Intra/Federator/Types.hs index 40c0b892680..7a316f7ce80 100644 --- a/services/galley/src/Galley/Intra/Federator/Types.hs +++ b/services/galley/src/Galley/Intra/Federator/Types.hs @@ -17,42 +17,12 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.Intra.Federator.Types - ( FederatedRPC, - FederationM, - runFederationM, - ) -where +module Galley.Intra.Federator.Types (FederatedRPC) where -import Control.Lens -import Control.Monad.Catch import Control.Monad.Except -import Galley.Env -import Galley.Options -import Imports +import Galley.Monad import Wire.API.Federation.Client import Wire.API.Federation.GRPC.Types type FederatedRPC (c :: Component) = - FederatorClient c (ExceptT FederationClientFailure FederationM) - -newtype FederationM a = FederationM - {unFederationM :: ReaderT Env IO a} - deriving - ( Functor, - Applicative, - Monad, - MonadIO, - MonadReader Env, - MonadUnliftIO, - MonadThrow, - MonadCatch, - MonadMask - ) - -runFederationM :: Env -> FederationM a -> IO a -runFederationM env = flip runReaderT env . unFederationM - -instance HasFederatorConfig FederationM where - federatorEndpoint = view federator - federationDomain = view (options . optSettings . setFederationDomain) + FederatorClient c (ExceptT FederationClientFailure App) diff --git a/services/galley/src/Galley/Intra/Journal.hs b/services/galley/src/Galley/Intra/Journal.hs index f4bf8cd0c77..7cfd6eb8f8f 100644 --- a/services/galley/src/Galley/Intra/Journal.hs +++ b/services/galley/src/Galley/Intra/Journal.hs @@ -29,61 +29,84 @@ import Control.Lens import Data.ByteString.Conversion import qualified Data.Currency as Currency import Data.Id -import Data.Proto import Data.Proto.Id import Data.ProtoLens (defMessage) import Data.Text (pack) +import Data.Time.Clock +import Data.Time.Clock.POSIX import Galley.API.Util -import Galley.App -import qualified Galley.Aws as Aws import Galley.Effects.TeamStore import qualified Galley.Options as Opts import Galley.Types.Teams import Imports hiding (head) import Numeric.Natural import Polysemy +import Polysemy.Input +import qualified Polysemy.TinyLog as P import Proto.TeamEvents (TeamEvent'EventData, TeamEvent'EventType (..)) import qualified Proto.TeamEvents_Fields as T import System.Logger (field, msg, val) -import qualified System.Logger.Class as Log -- [Note: journaling] -- Team journal operations to SQS are a no-op when the service -- is started without journaling arguments teamActivate :: - Member TeamStore r => + Members + '[ Input Opts.Opts, + Input UTCTime, + TeamStore, + P.TinyLog + ] + r => TeamId -> Natural -> Maybe Currency.Alpha -> Maybe TeamCreationTime -> - Galley r () + Sem r () teamActivate tid teamSize cur time = do billingUserIds <- getBillingUserIds tid Nothing journalEvent TeamEvent'TEAM_ACTIVATE tid (Just $ evData teamSize billingUserIds cur) time -teamUpdate :: TeamId -> Natural -> [UserId] -> Galley r () +teamUpdate :: + Members '[TeamStore, Input UTCTime] r => + TeamId -> + Natural -> + [UserId] -> + Sem r () teamUpdate tid teamSize billingUserIds = journalEvent TeamEvent'TEAM_UPDATE tid (Just $ evData teamSize billingUserIds Nothing) Nothing -teamDelete :: TeamId -> Galley r () +teamDelete :: + Members '[TeamStore, Input UTCTime] r => + TeamId -> + Sem r () teamDelete tid = journalEvent TeamEvent'TEAM_DELETE tid Nothing Nothing -teamSuspend :: TeamId -> Galley r () +teamSuspend :: + Members '[TeamStore, Input UTCTime] r => + TeamId -> + Sem r () teamSuspend tid = journalEvent TeamEvent'TEAM_SUSPEND tid Nothing Nothing -journalEvent :: TeamEvent'EventType -> TeamId -> Maybe TeamEvent'EventData -> Maybe TeamCreationTime -> Galley r () -journalEvent typ tid dat tim = - view aEnv >>= \mEnv -> for_ mEnv $ \e -> do - -- writetime is in microseconds in cassandra 3.11 - ts <- maybe now (return . (`div` 1000000) . view tcTime) tim - let ev = - defMessage - & T.eventType .~ typ - & T.teamId .~ toBytes tid - & T.utcTime .~ ts - & T.maybe'eventData .~ dat - Aws.execute e (Aws.enqueue ev) +journalEvent :: + Members '[TeamStore, Input UTCTime] r => + TeamEvent'EventType -> + TeamId -> + Maybe TeamEvent'EventData -> + Maybe TeamCreationTime -> + Sem r () +journalEvent typ tid dat tim = do + -- writetime is in microseconds in cassandra 3.11 + now <- round . utcTimeToPOSIXSeconds <$> input + let ts = maybe now ((`div` 1000000) . view tcTime) tim + ev = + defMessage + & T.eventType .~ typ + & T.teamId .~ toBytes tid + & T.utcTime .~ ts + & T.maybe'eventData .~ dat + enqueueTeamEvent ev ---------------------------------------------------------------------------- -- utils @@ -99,16 +122,23 @@ evData memberCount billingUserIds cur = -- 'getBillingTeamMembers'. This is required only until data is backfilled in the -- 'billing_team_user' table. getBillingUserIds :: - Member TeamStore r => + Members '[Input Opts.Opts, TeamStore, P.TinyLog] r => TeamId -> Maybe TeamMemberList -> - Galley r [UserId] + Sem r [UserId] getBillingUserIds tid maybeMemberList = do - enableIndexedBillingTeamMembers <- view (options . Opts.optSettings . Opts.setEnableIndexedBillingTeamMembers . to (fromMaybe False)) + opts <- input + let enableIndexedBillingTeamMembers = + view + ( Opts.optSettings + . Opts.setEnableIndexedBillingTeamMembers + . to (fromMaybe False) + ) + opts case maybeMemberList of Nothing -> if enableIndexedBillingTeamMembers - then liftSem $ fetchFromDB + then fetchFromDB else do mems <- getTeamMembersForFanout tid handleList enableIndexedBillingTeamMembers mems @@ -117,18 +147,18 @@ getBillingUserIds tid maybeMemberList = do fetchFromDB :: Member TeamStore r => Sem r [UserId] fetchFromDB = getBillingTeamMembers tid - filterFromMembers :: TeamMemberList -> Galley r [UserId] + filterFromMembers :: TeamMemberList -> Sem r [UserId] filterFromMembers list = pure $ map (view userId) $ filter (`hasPermission` SetBilling) (list ^. teamMembers) - handleList :: Member TeamStore r => Bool -> TeamMemberList -> Galley r [UserId] + handleList :: Members '[TeamStore, P.TinyLog] r => Bool -> TeamMemberList -> Sem r [UserId] handleList enableIndexedBillingTeamMembers list = case list ^. teamMemberListType of ListTruncated -> if enableIndexedBillingTeamMembers - then liftSem $ fetchFromDB + then fetchFromDB else do - Log.warn $ + P.warn $ field "team" (toByteString tid) . msg (val "TeamMemberList is incomplete, you may not see all the admin users in team. Please enable the indexedBillingTeamMembers feature.") filterFromMembers list diff --git a/services/galley/src/Galley/Intra/Push/Internal.hs b/services/galley/src/Galley/Intra/Push/Internal.hs index 6c4c7aefbca..7204753a8b9 100644 --- a/services/galley/src/Galley/Intra/Push/Internal.hs +++ b/services/galley/src/Galley/Intra/Push/Internal.hs @@ -22,7 +22,6 @@ module Galley.Intra.Push.Internal where import Bilge hiding (options) import Control.Lens (makeLenses, set, view, (.~)) import Data.Aeson (Object) -import Data.Domain import Data.Id (ConnId, UserId) import Data.Json.Util import Data.List.Extra (chunksOf) @@ -33,6 +32,8 @@ import Data.Range import qualified Data.Set as Set import Galley.Env import Galley.Intra.Util +import Galley.Monad +import Galley.Options import Galley.Types import qualified Galley.Types.Teams as Teams import Gundeck.Types.Push.V2 (RecipientClients (..)) @@ -79,7 +80,7 @@ makeLenses ''PushTo type Push = PushTo UserId -push :: Foldable f => f Push -> IntraM () +push :: Foldable f => f Push -> App () push ps = do let pushes = foldMap (toList . mkPushTo) ps traverse_ pushLocal (nonEmpty pushes) @@ -92,7 +93,7 @@ push ps = do -- | Asynchronously send multiple pushes, aggregating them into as -- few requests as possible, such that no single request targets -- more than 128 recipients. -pushLocal :: NonEmpty (PushTo UserId) -> IntraM () +pushLocal :: NonEmpty (PushTo UserId) -> App () pushLocal ps = do opts <- view options let limit = currentFanoutLimit opts @@ -162,7 +163,15 @@ newPush t u e (r : rr) = Just $ newPush1 t u e (list1 r rr) newPushLocal :: Teams.ListType -> UserId -> PushEvent -> [Recipient] -> Maybe Push newPushLocal lt uid e rr = newPush lt (Just uid) e rr -newConversationEventPush :: Domain -> Event -> [UserId] -> Maybe Push -newConversationEventPush localDomain e users = - let musr = guard (localDomain == qDomain (evtFrom e)) $> qUnqualified (evtFrom e) - in newPush Teams.ListComplete musr (ConvEvent e) (map userRecipient users) +newConversationEventPush :: Event -> Local [UserId] -> Maybe Push +newConversationEventPush e users = + let musr = guard (tDomain users == qDomain (evtFrom e)) $> qUnqualified (evtFrom e) + in newPush Teams.ListComplete musr (ConvEvent e) (map userRecipient (tUnqualified users)) + +pushSlowly :: Foldable f => f Push -> App () +pushSlowly ps = do + mmillis <- view (options . optSettings . setDeleteConvThrottleMillis) + let delay = 1000 * (fromMaybe defDeleteConvThrottleMillis mmillis) + forM_ ps $ \p -> do + push [p] + threadDelay delay diff --git a/services/galley/src/Galley/Intra/Spar.hs b/services/galley/src/Galley/Intra/Spar.hs index ce9f569a60d..73836adee43 100644 --- a/services/galley/src/Galley/Intra/Spar.hs +++ b/services/galley/src/Galley/Intra/Spar.hs @@ -24,11 +24,12 @@ import Bilge import Data.ByteString.Conversion import Data.Id import Galley.Intra.Util +import Galley.Monad import Imports import Network.HTTP.Types.Method -- | Notify Spar that a team is being deleted. -deleteTeam :: TeamId -> IntraM () +deleteTeam :: TeamId -> App () deleteTeam tid = do void . call Spar $ method DELETE diff --git a/services/galley/src/Galley/Intra/Team.hs b/services/galley/src/Galley/Intra/Team.hs index a6b8d96af1a..ad6f0e0ebf4 100644 --- a/services/galley/src/Galley/Intra/Team.hs +++ b/services/galley/src/Galley/Intra/Team.hs @@ -23,12 +23,13 @@ import Brig.Types.Team import Data.ByteString.Conversion import Data.Id import Galley.Intra.Util +import Galley.Monad import Imports import Network.HTTP.Types.Method import Network.HTTP.Types.Status import Network.Wai.Utilities.Error -getSize :: TeamId -> IntraM TeamSize +getSize :: TeamId -> App TeamSize getSize tid = do r <- call Brig $ diff --git a/services/galley/src/Galley/Intra/User.hs b/services/galley/src/Galley/Intra/User.hs index 0a08a634e0e..70a0483ebc7 100644 --- a/services/galley/src/Galley/Intra/User.hs +++ b/services/galley/src/Galley/Intra/User.hs @@ -27,6 +27,7 @@ module Galley.Intra.User getContactList, chunkify, getRichInfoMultiUser, + getAccountFeatureConfigClient, ) where @@ -35,20 +36,31 @@ import Bilge.RPC import Brig.Types.Connection (Relation (..), UpdateConnectionsInternal (..), UserIds (..)) import qualified Brig.Types.Intra as Brig import Brig.Types.User (User) +import Control.Lens (view, (^.)) import Control.Monad.Catch (throwM) import Data.ByteString.Char8 (pack) import qualified Data.ByteString.Char8 as BSC import Data.ByteString.Conversion import Data.Id +import Data.Proxy import Data.Qualified +import Data.String.Conversions +import Galley.API.Error +import Galley.Env import Galley.Intra.Util +import Galley.Monad import Imports import Network.HTTP.Client (HttpExceptionContent (..)) import qualified Network.HTTP.Client.Internal as Http import Network.HTTP.Types.Method import Network.HTTP.Types.Status import Network.Wai.Utilities.Error +import Servant.API ((:<|>) ((:<|>))) +import qualified Servant.Client as Client +import Util.Options +import qualified Wire.API.Routes.Internal.Brig as IAPI import Wire.API.Routes.Internal.Brig.Connection +import Wire.API.Team.Feature import Wire.API.User.RichInfo (RichInfo) -- | Get statuses of all connections between two groups of users (the usual @@ -61,7 +73,7 @@ getConnectionsUnqualified :: [UserId] -> Maybe [UserId] -> Maybe Relation -> - IntraM [ConnectionStatus] + App [ConnectionStatus] getConnectionsUnqualified uFrom uTo rlt = do r <- call Brig $ @@ -84,7 +96,7 @@ getConnections :: [UserId] -> Maybe [Qualified UserId] -> Maybe Relation -> - IntraM [ConnectionStatusV2] + App [ConnectionStatusV2] getConnections [] _ _ = pure [] getConnections uFrom uTo rlt = do r <- @@ -97,7 +109,7 @@ getConnections uFrom uTo rlt = do putConnectionInternal :: UpdateConnectionsInternal -> - IntraM Status + App Status putConnectionInternal updateConn = do response <- call Brig $ @@ -109,7 +121,7 @@ putConnectionInternal updateConn = do deleteBot :: ConvId -> BotId -> - IntraM () + App () deleteBot cid bot = do void $ call Brig $ @@ -124,7 +136,7 @@ deleteBot cid bot = do reAuthUser :: UserId -> Brig.ReAuthUser -> - IntraM Bool + App Bool reAuthUser uid auth = do let req = method GET @@ -143,7 +155,7 @@ check allowed r = } -- | Calls 'Brig.API.listActivatedAccountsH'. -lookupActivatedUsers :: [UserId] -> IntraM [User] +lookupActivatedUsers :: [UserId] -> App [User] lookupActivatedUsers = chunkify $ \uids -> do let users = BSC.intercalate "," $ toByteString' <$> uids r <- @@ -169,7 +181,7 @@ chunkify doChunk keys = mconcat <$> (doChunk `mapM` chunks keys) chunks uids = case splitAt maxSize uids of (h, t) -> h : chunks t -- | Calls 'Brig.API.listActivatedAccountsH'. -getUsers :: [UserId] -> IntraM [Brig.UserAccount] +getUsers :: [UserId] -> App [Brig.UserAccount] getUsers = chunkify $ \uids -> do resp <- call Brig $ @@ -180,7 +192,7 @@ getUsers = chunkify $ \uids -> do pure . fromMaybe [] . responseJsonMaybe $ resp -- | Calls 'Brig.API.deleteUserNoVerifyH'. -deleteUser :: UserId -> IntraM () +deleteUser :: UserId -> App () deleteUser uid = do void $ call Brig $ @@ -189,7 +201,7 @@ deleteUser uid = do . expect2xx -- | Calls 'Brig.API.getContactListH'. -getContactList :: UserId -> IntraM [UserId] +getContactList :: UserId -> App [UserId] getContactList uid = do r <- call Brig $ @@ -199,7 +211,7 @@ getContactList uid = do cUsers <$> parseResponse (mkError status502 "server-error") r -- | Calls 'Brig.API.Internal.getRichInfoMultiH' -getRichInfoMultiUser :: [UserId] -> IntraM [(UserId, RichInfo)] +getRichInfoMultiUser :: [UserId] -> App [(UserId, RichInfo)] getRichInfoMultiUser = chunkify $ \uids -> do resp <- call Brig $ @@ -208,3 +220,30 @@ getRichInfoMultiUser = chunkify $ \uids -> do . queryItem "ids" (toByteString' (List uids)) . expect2xx parseResponse (mkError status502 "server-error") resp + +getAccountFeatureConfigClient :: HasCallStack => UserId -> App TeamFeatureStatusNoConfig +getAccountFeatureConfigClient uid = + runHereClientM (getAccountFeatureConfigClientM uid) + >>= handleResp + where + handleResp :: + Either Client.ClientError TeamFeatureStatusNoConfig -> + App TeamFeatureStatusNoConfig + handleResp (Right cfg) = pure cfg + handleResp (Left errmsg) = throwM . internalErrorWithDescription . cs . show $ errmsg + +getAccountFeatureConfigClientM :: + UserId -> Client.ClientM TeamFeatureStatusNoConfig +( _ + :<|> getAccountFeatureConfigClientM + :<|> _ + :<|> _ + ) = Client.client (Proxy @IAPI.API) + +runHereClientM :: HasCallStack => Client.ClientM a -> App (Either Client.ClientError a) +runHereClientM action = do + mgr <- view manager + brigep <- view brig + let env = Client.mkClientEnv mgr baseurl + baseurl = Client.BaseUrl Client.Http (cs $ brigep ^. epHost) (fromIntegral $ brigep ^. epPort) "" + liftIO $ Client.runClientM action env diff --git a/services/galley/src/Galley/Intra/Util.hs b/services/galley/src/Galley/Intra/Util.hs index 203c6ab3901..17c83c5b0a8 100644 --- a/services/galley/src/Galley/Intra/Util.hs +++ b/services/galley/src/Galley/Intra/Util.hs @@ -19,8 +19,6 @@ module Galley.Intra.Util ( IntraComponent (..), - IntraM, - embedIntra, call, asyncCall, ) @@ -29,8 +27,7 @@ where import Bilge hiding (getHeader, options, statusCode) import Bilge.RPC import Bilge.Retry -import Cassandra (MonadClient (..), runClient) -import Control.Lens (locally, view, (^.)) +import Control.Lens (view, (^.)) import Control.Monad.Catch import Control.Retry import qualified Data.ByteString.Lazy as LB @@ -38,11 +35,10 @@ import Data.Misc (portNumber) import Data.Text.Encoding (encodeUtf8) import qualified Data.Text.Lazy as LT import Galley.Env +import Galley.Monad import Galley.Options import Imports hiding (log) import Network.HTTP.Types -import Polysemy -import qualified Polysemy.Reader as P import System.Logger import qualified System.Logger.Class as LC import Util.Options @@ -74,53 +70,17 @@ componentRetryPolicy Brig = x1 componentRetryPolicy Spar = x1 componentRetryPolicy Gundeck = x3 -embedIntra :: - Members '[Embed IO, P.Reader Env] r => - IntraM a -> - Sem r a -embedIntra action = do - env <- P.ask - embed $ runHttpT (env ^. manager) (runReaderT (unIntraM action) env) - -newtype IntraM a = IntraM {unIntraM :: ReaderT Env Http a} - deriving - ( Functor, - Applicative, - Monad, - MonadIO, - MonadHttp, - MonadThrow, - MonadCatch, - MonadMask, - MonadReader Env, - MonadUnliftIO - ) - -instance HasRequestId IntraM where - getRequestId = IntraM $ view reqId - -instance MonadClient IntraM where - liftClient m = do - cs <- view cstate - liftIO $ runClient cs m - localState f = locally cstate f - -instance LC.MonadLogger IntraM where - log lvl m = do - env <- ask - log (env ^. applog) lvl (reqIdMsg (env ^. reqId) . m) - call :: IntraComponent -> (Request -> Request) -> - IntraM (Response (Maybe LB.ByteString)) + App (Response (Maybe LB.ByteString)) call comp r = do o <- view options let r0 = componentRequest comp o let n = LT.pack (componentName comp) recovering (componentRetryPolicy comp) rpcHandlers (const (rpc n (r . r0))) -asyncCall :: IntraComponent -> (Request -> Request) -> IntraM () +asyncCall :: IntraComponent -> (Request -> Request) -> App () asyncCall comp req = void $ do let n = LT.pack (componentName comp) forkIO $ catches (void (call comp req)) (handlers n) diff --git a/services/galley/src/Galley/Monad.hs b/services/galley/src/Galley/Monad.hs new file mode 100644 index 00000000000..fe8a19eb9a6 --- /dev/null +++ b/services/galley/src/Galley/Monad.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- 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 . + +module Galley.Monad where + +import Bilge.IO hiding (options) +import Bilge.RPC +import Cassandra +import Control.Lens +import Control.Monad.Catch +import Control.Monad.Except +import Galley.Env +import Galley.Options +import Imports hiding (log) +import Polysemy +import Polysemy.Input +import System.Logger +import qualified System.Logger.Class as LC +import Wire.API.Federation.Client + +newtype App a = App {unApp :: ReaderT Env IO a} + deriving + ( Functor, + Applicative, + Monad, + MonadCatch, + MonadIO, + MonadMask, + MonadReader Env, + MonadThrow, + MonadUnliftIO + ) + +runApp :: Env -> App a -> IO a +runApp env = flip runReaderT env . unApp + +instance HasFederatorConfig App where + federatorEndpoint = view federator + federationDomain = view (options . optSettings . setFederationDomain) + +instance HasRequestId App where + getRequestId = App $ view reqId + +instance MonadHttp App where + handleRequestWithCont req h = do + m <- view manager + liftIO $ withResponse req m h + +instance MonadClient App where + liftClient m = do + cs <- view cstate + liftIO $ runClient cs m + localState f = locally cstate f + +instance LC.MonadLogger App where + log lvl m = do + env <- ask + log (env ^. applog) lvl (reqIdMsg (env ^. reqId) . m) + +embedApp :: + Members '[Embed IO, Input Env] r => + App a -> + Sem r a +embedApp action = do + env <- input + embed $ runApp env action diff --git a/services/galley/src/Galley/Queue.hs b/services/galley/src/Galley/Queue.hs index f143dadae73..96534fc84bd 100644 --- a/services/galley/src/Galley/Queue.hs +++ b/services/galley/src/Galley/Queue.hs @@ -23,12 +23,15 @@ module Galley.Queue tryPush, pop, len, + interpretQueue, ) where import qualified Control.Concurrent.STM as Stm +import qualified Galley.Effects.Queue as E import Imports import Numeric.Natural (Natural) +import Polysemy data Queue a = Queue { _len :: Stm.TVar Word, @@ -53,3 +56,12 @@ pop q = liftIO . atomically $ do len :: MonadIO m => Queue a -> m Word len q = liftIO $ Stm.readTVarIO (_len q) + +interpretQueue :: + Member (Embed IO) r => + Queue a -> + Sem (E.Queue a ': r) x -> + Sem r x +interpretQueue q = interpret $ \case + E.TryPush a -> embed @IO $ tryPush q a + E.Pop -> embed @IO $ pop q diff --git a/services/galley/src/Galley/Run.hs b/services/galley/src/Galley/Run.hs index a6e2e751531..907bd8c7cbd 100644 --- a/services/galley/src/Galley/Run.hs +++ b/services/galley/src/Galley/Run.hs @@ -27,6 +27,7 @@ import qualified Control.Concurrent.Async as Async import Control.Exception (finally) import Control.Lens (view, (^.)) import qualified Data.Aeson as Aeson +import Data.Domain import qualified Data.Metrics.Middleware as M import Data.Metrics.Servant (servantPlusWAIPrometheusMiddleware) import Data.Misc (portNumber) @@ -38,20 +39,17 @@ import qualified Galley.API.Internal as Internal import Galley.App import qualified Galley.App as App import Galley.Cassandra -import Galley.Options (Opts, optGalley) +import Galley.Monad +import Galley.Options import qualified Galley.Queue as Q import Imports import qualified Network.HTTP.Media.RenderHeader as HTTPMedia import qualified Network.HTTP.Types as HTTP -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 -import Servant (Context ((:.)), Proxy (Proxy)) -import Servant.API ((:<|>) ((:<|>))) -import qualified Servant.API as Servant -import Servant.API.Generic (ToServantApi, genericApi) -import qualified Servant.Server as Servant +import Servant hiding (route) +import Servant.API.Generic (ToServantApi) import qualified System.Logger as Log import Util.Options import qualified Wire.API.Federation.API.Galley as FederationGalley @@ -68,8 +66,8 @@ run o = do (portNumber $ fromIntegral $ o ^. optGalley . epPort) l (e ^. monitor) - deleteQueueThread <- Async.async $ evalGalley e Internal.deleteLoop - refreshMetricsThread <- Async.async $ evalGalley e refreshMetrics + deleteQueueThread <- Async.async $ runApp e Internal.deleteLoop + refreshMetricsThread <- Async.async $ runApp e refreshMetrics runSettingsWithShutdown s app 5 `finally` do Async.cancel deleteQueueThread Async.cancel refreshMetricsThread @@ -100,22 +98,39 @@ mkApp o = do servantApp e r = Servant.serveWithContext (Proxy @CombinedAPI) - (customFormatters :. Servant.EmptyContext) - ( Servant.hoistServer (Proxy @GalleyAPI.ServantAPI) (toServantHandler e) API.servantSitemap - :<|> Servant.hoistServer (Proxy @Internal.ServantAPI) (toServantHandler e) Internal.servantSitemap - :<|> Servant.hoistServer (genericApi (Proxy @FederationGalley.Api)) (toServantHandler e) federationSitemap + ( view (options . optSettings . setFederationDomain) e + :. customFormatters + :. Servant.EmptyContext + ) + ( hoistServer' @GalleyAPI.ServantAPI (toServantHandler e) API.servantSitemap + :<|> hoistServer' @Internal.ServantAPI (toServantHandler e) Internal.servantSitemap + :<|> hoistServer' @(ToServantApi FederationGalley.Api) (toServantHandler e) federationSitemap :<|> Servant.Tagged (app e) ) r +-- Servant needs a context type argument here that contains *at least* the +-- context types required by all the HasServer instances. In reality, this should +-- not be necessary, because the contexts are only used by the @route@ functions, +-- but unfortunately the 'hoistServerWithContext' function is also part of the +-- 'HasServer' typeclass, even though it cannot possibly make use of its @context@ +-- type argument. +hoistServer' :: + forall api m n. + HasServer api '[Domain] => + (forall x. m x -> n x) -> + ServerT api m -> + ServerT api n +hoistServer' = hoistServerWithContext (Proxy @api) (Proxy @'[Domain]) + customFormatters :: Servant.ErrorFormatters customFormatters = - Servant.defaultErrorFormatters - { Servant.bodyParserErrorFormatter = bodyParserErrorFormatter + defaultErrorFormatters + { bodyParserErrorFormatter = bodyParserErrorFormatter' } -bodyParserErrorFormatter :: Servant.ErrorFormatter -bodyParserErrorFormatter _ _ errMsg = +bodyParserErrorFormatter' :: Servant.ErrorFormatter +bodyParserErrorFormatter' _ _ errMsg = Servant.ServerError { Servant.errHTTPCode = HTTP.statusCode HTTP.status400, Servant.errReasonPhrase = cs $ HTTP.statusMessage HTTP.status400, @@ -131,8 +146,8 @@ bodyParserErrorFormatter _ _ errMsg = type CombinedAPI = GalleyAPI.ServantAPI :<|> Internal.ServantAPI :<|> ToServantApi FederationGalley.Api :<|> Servant.Raw -refreshMetrics :: Galley r () -refreshMetrics = liftGalley0 $ do +refreshMetrics :: App () +refreshMetrics = do m <- view monitor q <- view deleteQueue Internal.safeForever "refreshMetrics" $ do diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index 3bdb964a400..40c5be5010f 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -2264,8 +2264,8 @@ testBulkGetQualifiedConvs = do let expectedFound = sortOn cnvQualifiedId - $ maybeToList (remoteConversationView lAlice defMemberStatus (toRemoteUnsafe remoteDomainA mockConversationA)) - <> maybeToList (remoteConversationView lAlice defMemberStatus (toRemoteUnsafe remoteDomainB mockConversationB)) + $ pure (remoteConversationView lAlice defMemberStatus (toRemoteUnsafe remoteDomainA mockConversationA)) + <> pure (remoteConversationView lAlice defMemberStatus (toRemoteUnsafe remoteDomainB mockConversationB)) <> [localConv] actualFound = sortOn cnvQualifiedId $ crFound convs assertEqual "found conversations" expectedFound actualFound diff --git a/services/galley/test/integration/API/Teams.hs b/services/galley/test/integration/API/Teams.hs index 8a15a7a255c..43985abb00b 100644 --- a/services/galley/test/integration/API/Teams.hs +++ b/services/galley/test/integration/API/Teams.hs @@ -51,7 +51,7 @@ import qualified Data.UUID as UUID import qualified Data.UUID.Util as UUID import qualified Data.UUID.V1 as UUID import qualified Data.Vector as V -import qualified Galley.App as Galley +import qualified Galley.Env as Galley import Galley.Options (optSettings, setEnableIndexedBillingTeamMembers, setFeatureFlags, setMaxConvSize, setMaxFanoutSize) import Galley.Types hiding (EventData (..), EventType (..), MemberUpdate (..)) import Galley.Types.Conversations.Roles diff --git a/services/galley/test/integration/API/Teams/LegalHold.hs b/services/galley/test/integration/API/Teams/LegalHold.hs index b5d4cd24deb..7ccefd4ea6a 100644 --- a/services/galley/test/integration/API/Teams/LegalHold.hs +++ b/services/galley/test/integration/API/Teams/LegalHold.hs @@ -64,10 +64,10 @@ import qualified Data.Set as Set import Data.String.Conversions (LBS, cs) import Data.Text.Encoding (encodeUtf8) import qualified Data.Time.Clock as Time -import qualified Galley.App as Galley import Galley.Cassandra.Client +import Galley.Cassandra.LegalHold import qualified Galley.Cassandra.LegalHold as LegalHoldData -import Galley.External.LegalHoldService (validateServiceKey) +import qualified Galley.Env as Galley import Galley.Options (optSettings, setFeatureFlags) import qualified Galley.Types.Clients as Clients import Galley.Types.Teams diff --git a/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs b/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs index f7ce8108228..69059bff248 100644 --- a/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs +++ b/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs @@ -58,10 +58,10 @@ import Data.Range import qualified Data.Set as Set import Data.String.Conversions (LBS, cs) import Data.Text.Encoding (encodeUtf8) -import qualified Galley.App as Galley import Galley.Cassandra.Client +import Galley.Cassandra.LegalHold import qualified Galley.Cassandra.LegalHold as LegalHoldData -import Galley.External.LegalHoldService (validateServiceKey) +import qualified Galley.Env as Galley import Galley.Options (optSettings, setFeatureFlags) import qualified Galley.Types.Clients as Clients import Galley.Types.Teams diff --git a/services/galley/test/integration/API/Util.hs b/services/galley/test/integration/API/Util.hs index 2f7c43f6814..42a18927fb9 100644 --- a/services/galley/test/integration/API/Util.hs +++ b/services/galley/test/integration/API/Util.hs @@ -128,7 +128,7 @@ import Wire.API.User.Identity (mkSimpleSampleUref) ------------------------------------------------------------------------------- -- API Operations --- | A class for monads with access to a Galley r instance +-- | A class for monads with access to a Sem r instance class HasGalley m where viewGalley :: m GalleyR viewGalleyOpts :: m Opts.Opts From e8b3bb4d8cad284b0a7fa7ea47139877e38a1040 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Wed, 17 Nov 2021 07:45:49 +0100 Subject: [PATCH 04/28] Document Servant setup and combinators (#1933) --- changelog.d/4-docs/servant.md | 1 + docs/developer/servant.md | 33 +++++++++++++++++++++++++++++++++ 2 files changed, 34 insertions(+) create mode 100644 changelog.d/4-docs/servant.md create mode 100644 docs/developer/servant.md diff --git a/changelog.d/4-docs/servant.md b/changelog.d/4-docs/servant.md new file mode 100644 index 00000000000..88e2b148dfd --- /dev/null +++ b/changelog.d/4-docs/servant.md @@ -0,0 +1 @@ +Document servant setup and combinators diff --git a/docs/developer/servant.md b/docs/developer/servant.md new file mode 100644 index 00000000000..07e003facbc --- /dev/null +++ b/docs/developer/servant.md @@ -0,0 +1,33 @@ +# Introduction + +We currently use Servant for the public (i.e. client-facing) API in brig, galley and spar, as well as for their federation (i.e. server-to-server) and internal API. + +Client-facing APIs are defined in `Wire.API.Routes.Public.{Brig,Galley}`. Internal APIs are all over the place at the moment. Federation APIs are in `Wire.API.Federation.API.{Brig,Galley}`. + +Our APIs are able to generate Swagger documentation semi-automatically using `servant-swagger2`. The `schema-profunctor` library (see README in libs/schema-profunctor) is used to create "schemas" for the input and output types used in the Servant APIs. A schema contains all the information needed to serialise/deserialise JSON values, as well as the documentation and metadata needed to generate Swagger. + +# Combinators + +We have employed a few custom combinators to try to keep HTTP concerns and vocabulary out of the API handlers that actually implement the functionality of the API. + +## `ZAuth` + +This is a family of combinators to handle the headers that nginx adds to requests. We currently have: + + - `ZUser`: extracts the `UserId` in the `Z-User` header. + - `ZLocalUser`: same as `ZUser`, but as a `Local` object (i.e. qualified by the local domain); this is useful when writing federation-aware handlers. + - `ZConn`: extracts the `ConnId` in the `Z-Connection` header. + +## `MultiVerb` + +This is an alternative to `UVerb`, designed to prevent any HTTP-specific information from leaking into the type of the handler. Use this for endpoints that can return multiple responses. + +## `CanThrow` + +This can be used to add an error response to the Swagger documentation. It currently does nothing to the Servant API itself, but this might change in the future, as polysemy is introduced in more services and integrated with Servant. The argument of `CanThrow` can be an `ErrorDescription` type, which is a type-level representation of a possible error. + +Note thtat `ErrorDescription` types can also be used directly as `MultiVerb` responses. This is useful for handlers that can return errors as part of their return type, instead of simply throwing them as IO exceptions. If an error is part of `MultiVerb`, there is no need to also report it with `CanThrow`. + +## `QualifiedCapture` + +This is a capture combinator for a path that looks like `/:domain/:value`, where `value` is of some arbitrary type `a`. The value is returned as a value of type `Qualified a`, which can then be used in federation-aware endpoints. From 68278f30f28442365abda3ff9b7a6e1369d5decd Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Wed, 17 Nov 2021 09:22:38 +0100 Subject: [PATCH 05/28] charts/wire-server-metrics: Use kube-prometheus-stack (#1915) The old version of prometheus operator chart is no longer compatible with latest K8s versions. The chart has also since moved to kube-prometheus-stack on the prometheus-community helm chart reposistory from the helm-stable repository. The kube-prometheus-stack helm chart also allows creating dashboard using labels on configmaps, so now we don't have to refer to non-pinned versions of the dashboard definitions. Instead each dashboard now becomes a configmap with a specific label and grafana discovers it. This commit also updates the dashboards to use new ways of addressing the pods which came with the move from old version of prometheus-operator chart to the kube-prometheus-stack chart. Along with these changes, the dashboards now also use the qualified endpoints and federation endpoints to display information about prekey claims and message sending stats. --- Makefile | 2 +- changelog.d/2-features/metrics | 1 + .../dashboards/message-stats.json | 770 ++++++++++++------ .../dashboards/services.json | 181 ++-- charts/wire-server-metrics/requirements.yaml | 6 +- .../templates/wire-server-dashboards.yaml | 23 + charts/wire-server-metrics/values.yaml | 28 +- 7 files changed, 670 insertions(+), 341 deletions(-) create mode 100644 changelog.d/2-features/metrics create mode 100644 charts/wire-server-metrics/templates/wire-server-dashboards.yaml diff --git a/Makefile b/Makefile index bcedd573e34..09c4f5b6221 100644 --- a/Makefile +++ b/Makefile @@ -8,7 +8,7 @@ DOCKER_TAG ?= $(USER) # default helm chart version must be 0.0.42 for local development (because 42 is the answer to the universe and everything) HELM_SEMVER ?= 0.0.42 # The list of helm charts needed for integration tests on kubernetes -CHARTS_INTEGRATION := wire-server databases-ephemeral fake-aws nginx-ingress-controller nginx-ingress-services +CHARTS_INTEGRATION := wire-server databases-ephemeral fake-aws nginx-ingress-controller nginx-ingress-services wire-server-metrics # The list of helm charts to publish on S3 # FUTUREWORK: after we "inline local subcharts", # (e.g. move charts/brig to charts/wire-server/brig) diff --git a/changelog.d/2-features/metrics b/changelog.d/2-features/metrics new file mode 100644 index 00000000000..a4650c4123a --- /dev/null +++ b/changelog.d/2-features/metrics @@ -0,0 +1 @@ +Use kube-prometheus-stack instead of prometheus-operator and update grafana dashboards for compatibility and add federation endpoints to relevant queries. \ No newline at end of file diff --git a/charts/wire-server-metrics/dashboards/message-stats.json b/charts/wire-server-metrics/dashboards/message-stats.json index e84580b8d0f..027a2a55b62 100644 --- a/charts/wire-server-metrics/dashboards/message-stats.json +++ b/charts/wire-server-metrics/dashboards/message-stats.json @@ -8,19 +8,31 @@ "hide": true, "iconColor": "rgba(0, 211, 255, 1)", "name": "Annotations & Alerts", + "target": { + "limit": 100, + "matchAny": false, + "tags": [], + "type": "dashboard" + }, "type": "dashboard" } ] }, "editable": true, + "fiscalYearStartMonth": 0, "gnetId": null, "graphTooltip": 0, - "id": 50, - "iteration": 1584951112798, + "iteration": 1637052673609, "links": [], + "liveNow": false, "panels": [ { "collapsed": false, + "datasource": null, + "fieldConfig": { + "defaults": {}, + "overrides": [] + }, "gridPos": { "h": 1, "w": 24, @@ -38,13 +50,16 @@ "dashLength": 10, "dashes": false, "datasource": "default", + "description": "", "fill": 3, + "fillGradient": 0, "gridPos": { "h": 7, "w": 12, "x": 0, "y": 1 }, + "hiddenSeries": false, "id": 17, "legend": { "avg": false, @@ -59,8 +74,12 @@ "linewidth": 2, "links": [], "nullPointMode": "null", + "options": { + "alertThreshold": true + }, "paceLength": 10, "percentage": false, + "pluginVersion": "8.2.3", "pointradius": 2, "points": false, "renderer": "flot", @@ -98,7 +117,7 @@ "timeFrom": null, "timeRegions": [], "timeShift": null, - "title": "Registrations/invitations/code requests (brig)", + "title": "Registrations/invitations/code requests", "tooltip": { "shared": true, "sort": 0, @@ -135,131 +154,256 @@ "alignLevel": null } }, + { + "datasource": null, + "description": "A client can fetch many prekeys with one API call, so the count here just represents how many calls are made to the API", + "fieldConfig": { + "defaults": { + "color": { + "mode": "palette-classic" + }, + "custom": { + "axisLabel": "", + "axisPlacement": "auto", + "barAlignment": 0, + "drawStyle": "line", + "fillOpacity": 0, + "gradientMode": "none", + "hideFrom": { + "legend": false, + "tooltip": false, + "viz": false + }, + "lineInterpolation": "linear", + "lineWidth": 1, + "pointSize": 5, + "scaleDistribution": { + "type": "linear" + }, + "showPoints": "auto", + "spanNulls": false, + "stacking": { + "group": "A", + "mode": "none" + }, + "thresholdsStyle": { + "mode": "off" + } + }, + "mappings": [], + "thresholds": { + "mode": "absolute", + "steps": [ + { + "color": "green", + "value": null + }, + { + "color": "red", + "value": 80 + } + ] + } + }, + "overrides": [] + }, + "gridPos": { + "h": 7, + "w": 12, + "x": 12, + "y": 1 + }, + "id": 34, + "options": { + "legend": { + "calcs": [], + "displayMode": "list", + "placement": "bottom" + }, + "tooltip": { + "mode": "single" + } + }, + "targets": [ + { + "exemplar": true, + "expr": "sum(rate(http_request_duration_seconds_count{namespace=\"$namespace\", handler=~\"/federation/claim-multi-prekey-bundle|/users/:uid/prekeys/:client|/users/:uid_domain/:uid/prekeys/:client|/users/:uid/prekeys|/users/:uid_domain/:uid/prekeys/users/prekys|/users/list-prekeys\"}[5m]))", + "interval": "", + "legendFormat": "API Calls", + "refId": "A" + } + ], + "title": "Prekey fetch count", + "type": "timeseries" + }, { "collapsed": false, + "datasource": null, + "fieldConfig": { + "defaults": {}, + "overrides": [] + }, "gridPos": { "h": 1, "w": 24, "x": 0, "y": 8 }, - "id": 23, + "id": 19, "panels": [], - "title": "Cannon Stats", + "title": "Galley Stats", "type": "row" }, { - "aliasColors": {}, - "bars": false, - "dashLength": 10, - "dashes": false, + "cards": { + "cardPadding": null, + "cardRound": null + }, + "color": { + "cardColor": "#8F3BB8", + "colorScale": "sqrt", + "colorScheme": "interpolateOranges", + "exponent": 0.5, + "mode": "spectrum" + }, + "dataFormat": "tsbuckets", "datasource": "default", - "fill": 2, + "description": "Includes messages that originate from local clients or remote users in local conversations", "gridPos": { "h": 7, "w": 12, "x": 0, "y": 9 }, - "id": 15, + "heatmap": {}, + "hideZeroBuckets": true, + "highlightCards": true, + "id": 6, "legend": { - "avg": false, - "current": false, - "max": false, - "min": false, - "show": true, - "total": false, - "values": false + "show": false }, - "lines": true, - "linewidth": 1, "links": [], - "nullPointMode": "null", - "paceLength": 10, - "percentage": false, - "pointradius": 2, - "points": false, - "renderer": "flot", - "seriesOverrides": [], - "spaceLength": 10, - "stack": false, - "steppedLine": false, + "reverseYBuckets": false, "targets": [ { - "expr": "sum(net_websocket_clients{namespace=\"$namespace\"})", - "format": "time_series", - "intervalFactor": 1, - "legendFormat": "Connected Clients", - "refId": "A" + "exemplar": true, + "expr": "sum(increase(http_request_duration_seconds_bucket{handler=~\"(/conversations/:cnv/otr/messages|/conversations/:cnv_domain/:cnv/proteus/messages|/federation/send-message)\", namespace=\"$namespace\"}[5m])) by (le)", + "format": "heatmap", + "instant": false, + "interval": "", + "intervalFactor": 10, + "legendFormat": "{{ le }}", + "refId": "B" } ], - "thresholds": [], "timeFrom": null, - "timeRegions": [], "timeShift": null, - "title": "Connected Clients (cannon)", + "title": "Message sending latencies for local and remote conversations", "tooltip": { - "shared": true, - "sort": 0, - "value_type": "individual" + "show": true, + "showHistogram": false }, - "type": "graph", - "xaxis": { - "buckets": null, - "mode": "time", - "name": null, + "type": "heatmap", + "xAxis": { + "show": true + }, + "xBucketNumber": null, + "xBucketSize": null, + "yAxis": { + "decimals": null, + "format": "short", + "logBase": 1, + "max": null, + "min": null, "show": true, - "values": [] + "splitFactor": null }, - "yaxes": [ - { - "format": "short", - "label": null, - "logBase": 1, - "max": null, - "min": null, - "show": true - }, - { - "format": "short", - "label": null, - "logBase": 1, - "max": null, - "min": null, - "show": true - } - ], - "yaxis": { - "align": false, - "alignLevel": null - } + "yBucketBound": "auto", + "yBucketNumber": null, + "yBucketSize": null }, { - "collapsed": false, + "cards": { + "cardPadding": null, + "cardRound": null + }, + "color": { + "cardColor": "#b4ff00", + "colorScale": "sqrt", + "colorScheme": "interpolateOranges", + "exponent": 0.5, + "mode": "spectrum" + }, + "dataFormat": "tsbuckets", + "datasource": null, + "description": "", "gridPos": { - "h": 1, - "w": 24, - "x": 0, - "y": 16 + "h": 7, + "w": 12, + "x": 12, + "y": 9 }, - "id": 30, - "panels": [], - "title": "Cargohold stats", - "type": "row" + "heatmap": {}, + "hideZeroBuckets": true, + "highlightCards": true, + "id": 32, + "legend": { + "show": false + }, + "reverseYBuckets": false, + "targets": [ + { + "exemplar": true, + "expr": "sum(increase(http_request_duration_seconds_bucket{handler=\"/federation/on-message-sent\", namespace=\"$namespace\"}[5m])) by (le)", + "format": "heatmap", + "instant": false, + "interval": "", + "intervalFactor": 10, + "legendFormat": "{{le}}", + "refId": "A" + } + ], + "title": "Latencies for messages received from remote conversations", + "tooltip": { + "show": true, + "showHistogram": false + }, + "type": "heatmap", + "xAxis": { + "show": true + }, + "xBucketNumber": null, + "xBucketSize": null, + "yAxis": { + "decimals": null, + "format": "short", + "logBase": 1, + "max": null, + "min": null, + "show": true, + "splitFactor": null + }, + "yBucketBound": "auto", + "yBucketNumber": null, + "yBucketSize": null }, { "aliasColors": {}, "bars": false, "dashLength": 10, "dashes": false, + "datasource": "default", + "description": "Messages sent from local clients to remote conversations are duplicated, if there are any other local clients involved", "fill": 1, + "fillGradient": 0, "gridPos": { - "h": 8, + "h": 7, "w": 12, "x": 0, - "y": 17 + "y": 16 }, - "id": 28, + "hiddenSeries": false, + "id": 11, "legend": { "avg": false, "current": false, @@ -273,8 +417,12 @@ "linewidth": 1, "links": [], "nullPointMode": "null", - "options": {}, + "options": { + "alertThreshold": true + }, + "paceLength": 10, "percentage": false, + "pluginVersion": "8.2.3", "pointradius": 2, "points": false, "renderer": "flot", @@ -284,25 +432,20 @@ "steppedLine": false, "targets": [ { - "expr": "sum(rate(http_request_duration_seconds_count{handler=\"/assets/v3\", status_code=\"201\", namespace=\"$namespace\"}[5m]))", + "exemplar": true, + "expr": "sum(increase(http_request_duration_seconds_count{handler=~\"(/conversations/:cnv/otr/messages|/conversations/:cnv_domain/:cnv/proteus/messages|/federation/send-message|/federation/on-message-sent)\", status_code=~\"2..\", namespace=\"$namespace\"}[5m]))", "format": "time_series", + "interval": "", "intervalFactor": 1, - "legendFormat": "uploaded/sec", + "legendFormat": "Messages sent", "refId": "A" - }, - { - "expr": "sum(rate(http_request_duration_seconds_count{handler=\"/assets/v3/:key\", status_code=\"302\", namespace=\"$namespace\"}[5m]))\n", - "format": "time_series", - "intervalFactor": 1, - "legendFormat": "downloaded/sec", - "refId": "B" } ], "thresholds": [], "timeFrom": null, "timeRegions": [], "timeShift": null, - "title": "Assets (cargohold)", + "title": "Messages Sent every 5m", "tooltip": { "shared": true, "sort": 0, @@ -334,90 +477,10 @@ "show": true } ], - "yaxis": { - "align": false, - "alignLevel": null - } - }, - { - "collapsed": false, - "gridPos": { - "h": 1, - "w": 24, - "x": 0, - "y": 25 - }, - "id": 21, - "panels": [], - "title": "Gundeck Stats", - "type": "row" - }, - { - "cards": { - "cardPadding": null, - "cardRound": null - }, - "color": { - "cardColor": "#8F3BB8", - "colorScale": "sqrt", - "colorScheme": "interpolateOranges", - "exponent": 0.5, - "mode": "spectrum" - }, - "dataFormat": "tsbuckets", - "datasource": "default", - "gridPos": { - "h": 7, - "w": 12, - "x": 0, - "y": 26 - }, - "heatmap": {}, - "hideZeroBuckets": true, - "highlightCards": true, - "id": 7, - "legend": { - "show": false - }, - "links": [], - "options": {}, - "reverseYBuckets": false, - "targets": [ - { - "expr": "sum(increase(http_request_duration_seconds_bucket{handler=\"/i/push/v2\", namespace=\"$namespace\"}[5m])) by (le)", - "format": "heatmap", - "instant": false, - "interval": "", - "intervalFactor": 10, - "legendFormat": "{{ le }}", - "refId": "B" - } - ], - "timeFrom": null, - "timeShift": null, - "title": "Message Push Latencies (gundeck)", - "tooltip": { - "show": true, - "showHistogram": false - }, - "type": "heatmap", - "xAxis": { - "show": true - }, - "xBucketNumber": null, - "xBucketSize": null, - "yAxis": { - "decimals": null, - "format": "short", - "logBase": 1, - "max": null, - "min": null, - "show": true, - "splitFactor": null - }, - "yBucketBound": "auto", - "yBucketNumber": null, - "yBucketSize": null + "yaxis": { + "align": false, + "alignLevel": null + } }, { "aliasColors": {}, @@ -425,17 +488,21 @@ "dashLength": 10, "dashes": false, "datasource": "default", - "fill": 1, + "description": "Does not include federation endpoints as they do not express errors in HTTP status", + "fill": 8, + "fillGradient": 0, "gridPos": { "h": 7, "w": 12, "x": 12, - "y": 26 + "y": 16 }, - "id": 9, + "hiddenSeries": false, + "id": 13, "legend": { "avg": false, "current": false, + "hideEmpty": false, "max": false, "min": false, "show": true, @@ -446,55 +513,54 @@ "linewidth": 1, "links": [], "nullPointMode": "null", - "options": {}, + "options": { + "alertThreshold": true + }, "paceLength": 10, - "percentage": false, + "percentage": true, + "pluginVersion": "8.2.3", "pointradius": 2, "points": false, "renderer": "flot", "seriesOverrides": [], "spaceLength": 10, - "stack": false, + "stack": true, "steppedLine": false, "targets": [ { - "expr": "sum(increase(push_native_success[5m]))", + "exemplar": true, + "expr": "sum(increase(http_request_duration_seconds_count{role=\"galley\", handler=~\"(/conversations/:cnv/otr/messages|/conversations/:cnv_domain/:cnv/proteus/messages)\", status_code=~\"2..\", namespace=\"$namespace\"}[10m]))", "format": "time_series", - "instant": false, - "intervalFactor": 1, - "legendFormat": "Success", + "interval": "", + "intervalFactor": 5, + "legendFormat": "2XX", "refId": "A" }, { - "expr": "-sum(increase(push_native_disabled[5m]))", + "exemplar": true, + "expr": "sum(increase(http_request_duration_seconds_count{role=\"galley\", handler=~\"(/conversations/:cnv/otr/messages|/conversations/:cnv_domain/:cnv/proteus/messages)\", status_code=~\"4..\", namespace=\"$namespace\"}[10m]))", "format": "time_series", - "instant": false, - "intervalFactor": 1, - "legendFormat": "-Disabled", + "hide": false, + "interval": "", + "intervalFactor": 5, + "legendFormat": "4XX", "refId": "B" }, { - "expr": "-sum(increase(push_native_invalid{namespace=\"$namespace\"}[5m]))", + "exemplar": true, + "expr": "sum(increase(http_request_duration_seconds_count{role=\"galley\", handler=~\"(/conversations/:cnv/otr/messages|/conversations/:cnv_domain/:cnv/proteus/messages)\", status_code=~\"5..\", namespace=\"$namespace\"}[10m]))", "format": "time_series", - "instant": false, - "intervalFactor": 1, - "legendFormat": "-Invalid", + "interval": "", + "intervalFactor": 5, + "legendFormat": "5XX", "refId": "C" - }, - { - "expr": "-sum(increase(push_native_errors{namespace=\"$namespace\"}[5m]))", - "format": "time_series", - "instant": false, - "intervalFactor": 1, - "legendFormat": "-Errors", - "refId": "D" } ], "thresholds": [], "timeFrom": null, "timeRegions": [], "timeShift": null, - "title": "Native Push (Outgoing) (gundeck)", + "title": "Proteus Message Receives as % by Status Code", "tooltip": { "shared": true, "sort": 0, @@ -513,7 +579,7 @@ "format": "short", "label": null, "logBase": 1, - "max": null, + "max": "100", "min": null, "show": true }, @@ -531,20 +597,41 @@ "alignLevel": null } }, + { + "collapsed": false, + "datasource": null, + "fieldConfig": { + "defaults": {}, + "overrides": [] + }, + "gridPos": { + "h": 1, + "w": 24, + "x": 0, + "y": 23 + }, + "id": 23, + "panels": [], + "title": "Cannon Stats", + "type": "row" + }, { "aliasColors": {}, "bars": false, "dashLength": 10, "dashes": false, "datasource": "default", - "fill": 1, + "description": "", + "fill": 2, + "fillGradient": 0, "gridPos": { "h": 7, "w": 12, "x": 0, - "y": 33 + "y": 24 }, - "id": 2, + "hiddenSeries": false, + "id": 15, "legend": { "avg": false, "current": false, @@ -558,9 +645,12 @@ "linewidth": 1, "links": [], "nullPointMode": "null", - "options": {}, + "options": { + "alertThreshold": true + }, "paceLength": 10, "percentage": false, + "pluginVersion": "8.2.3", "pointradius": 2, "points": false, "renderer": "flot", @@ -570,10 +660,10 @@ "steppedLine": false, "targets": [ { - "expr": "sum(increase(http_request_duration_seconds_count{role=\"gundeck\", handler=\"/i/push/v2\", namespace=\"$namespace\"}[5m])) by (status_code)", + "expr": "sum(net_websocket_clients{namespace=\"$namespace\"})", "format": "time_series", "intervalFactor": 1, - "legendFormat": "{{ status_code }}", + "legendFormat": "Connected Clients", "refId": "A" } ], @@ -581,7 +671,7 @@ "timeFrom": null, "timeRegions": [], "timeShift": null, - "title": "Push Rate (incoming) (gundeck)", + "title": "Connected Clients", "tooltip": { "shared": true, "sort": 0, @@ -618,20 +708,40 @@ "alignLevel": null } }, + { + "collapsed": false, + "datasource": null, + "fieldConfig": { + "defaults": {}, + "overrides": [] + }, + "gridPos": { + "h": 1, + "w": 24, + "x": 0, + "y": 31 + }, + "id": 30, + "panels": [], + "title": "Cargohold stats", + "type": "row" + }, { "aliasColors": {}, "bars": false, "dashLength": 10, "dashes": false, - "datasource": "default", + "datasource": null, "fill": 1, + "fillGradient": 0, "gridPos": { - "h": 7, + "h": 8, "w": 12, - "x": 12, - "y": 33 + "x": 0, + "y": 32 }, - "id": 4, + "hiddenSeries": false, + "id": 28, "legend": { "avg": false, "current": false, @@ -645,30 +755,39 @@ "linewidth": 1, "links": [], "nullPointMode": "null", - "options": {}, - "paceLength": 10, - "percentage": true, + "options": { + "alertThreshold": true + }, + "percentage": false, + "pluginVersion": "8.2.3", "pointradius": 2, "points": false, "renderer": "flot", "seriesOverrides": [], "spaceLength": 10, - "stack": true, + "stack": false, "steppedLine": false, "targets": [ { - "expr": "sum(http_request_duration_seconds_count{handler=\"/i/push/v2\", namespace=\"$namespace\"}) by (status_code)", + "expr": "sum(rate(http_request_duration_seconds_count{handler=\"/assets/v3\", status_code=\"201\", namespace=\"$namespace\"}[5m]))", "format": "time_series", "intervalFactor": 1, - "legendFormat": "{{ status_code }}", + "legendFormat": "uploaded/sec", "refId": "A" + }, + { + "expr": "sum(rate(http_request_duration_seconds_count{handler=\"/assets/v3/:key\", status_code=\"302\", namespace=\"$namespace\"}[5m]))\n", + "format": "time_series", + "intervalFactor": 1, + "legendFormat": "downloaded/sec", + "refId": "B" } ], "thresholds": [], "timeFrom": null, "timeRegions": [], "timeShift": null, - "title": "Push Status Codes as % (gundeck)", + "title": "Assets", "tooltip": { "shared": true, "sort": 0, @@ -685,15 +804,15 @@ "yaxes": [ { "format": "short", - "label": "", + "label": null, "logBase": 1, - "max": "100", - "min": "0", + "max": null, + "min": null, "show": true }, { "format": "short", - "label": "", + "label": null, "logBase": 1, "max": null, "min": null, @@ -707,15 +826,20 @@ }, { "collapsed": false, + "datasource": null, + "fieldConfig": { + "defaults": {}, + "overrides": [] + }, "gridPos": { "h": 1, "w": 24, "x": 0, "y": 40 }, - "id": 19, + "id": 21, "panels": [], - "title": "Galley Stats", + "title": "Gundeck Stats", "type": "row" }, { @@ -741,16 +865,15 @@ "heatmap": {}, "hideZeroBuckets": true, "highlightCards": true, - "id": 6, + "id": 7, "legend": { "show": false }, "links": [], - "options": {}, "reverseYBuckets": false, "targets": [ { - "expr": "sum(increase(http_request_duration_seconds_bucket{handler=\"/conversations/:cnv/otr/messages\", namespace=\"$namespace\"}[5m])) by (le)", + "expr": "sum(increase(http_request_duration_seconds_bucket{handler=\"/i/push/v2\", namespace=\"$namespace\"}[5m])) by (le)", "format": "heatmap", "instant": false, "interval": "", @@ -761,7 +884,7 @@ ], "timeFrom": null, "timeShift": null, - "title": "Message POSTing Latencies (galley)", + "title": "Message Push Latencies", "tooltip": { "show": true, "showHistogram": false @@ -791,18 +914,19 @@ "dashLength": 10, "dashes": false, "datasource": "default", - "fill": 8, + "fill": 1, + "fillGradient": 0, "gridPos": { "h": 7, "w": 12, "x": 12, "y": 41 }, - "id": 13, + "hiddenSeries": false, + "id": 9, "legend": { "avg": false, "current": false, - "hideEmpty": false, "max": false, "min": false, "show": true, @@ -813,45 +937,58 @@ "linewidth": 1, "links": [], "nullPointMode": "null", - "options": {}, + "options": { + "alertThreshold": true + }, "paceLength": 10, - "percentage": true, + "percentage": false, + "pluginVersion": "8.2.3", "pointradius": 2, "points": false, "renderer": "flot", "seriesOverrides": [], "spaceLength": 10, - "stack": true, + "stack": false, "steppedLine": false, "targets": [ { - "expr": "sum(increase(http_request_duration_seconds_count{role=\"galley\", handler=\"/conversations/:cnv/otr/messages\", status_code=~\"2..\", namespace=\"$namespace\"}[10m]))", + "expr": "sum(increase(push_native_success[5m]))", "format": "time_series", - "intervalFactor": 5, - "legendFormat": "2XX", + "instant": false, + "intervalFactor": 1, + "legendFormat": "Success", "refId": "A" }, { - "expr": "sum(increase(http_request_duration_seconds_count{role=\"galley\", handler=\"/conversations/:cnv/otr/messages\", status_code=~\"4..\", namespace=\"$namespace\"}[10m]))", + "expr": "-sum(increase(push_native_disabled[5m]))", "format": "time_series", - "hide": false, - "intervalFactor": 5, - "legendFormat": "4XX", + "instant": false, + "intervalFactor": 1, + "legendFormat": "-Disabled", "refId": "B" }, { - "expr": "sum(increase(http_request_duration_seconds_count{role=\"galley\", handler=\"/conversations/:cnv/otr/messages\", status_code=~\"5..\", namespace=\"$namespace\"}[10m]))", + "expr": "-sum(increase(push_native_invalid{namespace=\"$namespace\"}[5m]))", "format": "time_series", - "intervalFactor": 5, - "legendFormat": "5XX", + "instant": false, + "intervalFactor": 1, + "legendFormat": "-Invalid", "refId": "C" + }, + { + "expr": "-sum(increase(push_native_errors{namespace=\"$namespace\"}[5m]))", + "format": "time_series", + "instant": false, + "intervalFactor": 1, + "legendFormat": "-Errors", + "refId": "D" } ], "thresholds": [], "timeFrom": null, "timeRegions": [], "timeShift": null, - "title": "OTR Message Receives as % by Status Code (galley)", + "title": "Native Push (Outgoing)", "tooltip": { "shared": true, "sort": 0, @@ -870,7 +1007,7 @@ "format": "short", "label": null, "logBase": 1, - "max": "100", + "max": null, "min": null, "show": true }, @@ -895,13 +1032,15 @@ "dashes": false, "datasource": "default", "fill": 1, + "fillGradient": 0, "gridPos": { - "h": 8, + "h": 7, "w": 12, "x": 0, "y": 48 }, - "id": 11, + "hiddenSeries": false, + "id": 2, "legend": { "avg": false, "current": false, @@ -915,9 +1054,12 @@ "linewidth": 1, "links": [], "nullPointMode": "null", - "options": {}, + "options": { + "alertThreshold": true + }, "paceLength": 10, "percentage": false, + "pluginVersion": "8.2.3", "pointradius": 2, "points": false, "renderer": "flot", @@ -927,10 +1069,10 @@ "steppedLine": false, "targets": [ { - "expr": "sum(increase(http_request_duration_seconds_count{handler=\"/conversations/:cnv/otr/messages\", status_code=~\"2..\", namespace=\"$namespace\"}[5m]))", + "expr": "sum(increase(http_request_duration_seconds_count{role=\"gundeck\", handler=\"/i/push/v2\", namespace=\"$namespace\"}[5m])) by (status_code)", "format": "time_series", "intervalFactor": 1, - "legendFormat": "", + "legendFormat": "{{ status_code }}", "refId": "A" } ], @@ -938,7 +1080,7 @@ "timeFrom": null, "timeRegions": [], "timeShift": null, - "title": "Messages Sent every 5m (galley)", + "title": "Push Rate (incoming)", "tooltip": { "shared": true, "sort": 0, @@ -974,9 +1116,101 @@ "align": false, "alignLevel": null } + }, + { + "aliasColors": {}, + "bars": false, + "dashLength": 10, + "dashes": false, + "datasource": "default", + "fill": 1, + "fillGradient": 0, + "gridPos": { + "h": 7, + "w": 12, + "x": 12, + "y": 48 + }, + "hiddenSeries": false, + "id": 4, + "legend": { + "avg": false, + "current": false, + "max": false, + "min": false, + "show": true, + "total": false, + "values": false + }, + "lines": true, + "linewidth": 1, + "links": [], + "nullPointMode": "null", + "options": { + "alertThreshold": true + }, + "paceLength": 10, + "percentage": true, + "pluginVersion": "8.2.3", + "pointradius": 2, + "points": false, + "renderer": "flot", + "seriesOverrides": [], + "spaceLength": 10, + "stack": true, + "steppedLine": false, + "targets": [ + { + "expr": "sum(http_request_duration_seconds_count{handler=\"/i/push/v2\", namespace=\"$namespace\"}) by (status_code)", + "format": "time_series", + "intervalFactor": 1, + "legendFormat": "{{ status_code }}", + "refId": "A" + } + ], + "thresholds": [], + "timeFrom": null, + "timeRegions": [], + "timeShift": null, + "title": "Push Status Codes as %", + "tooltip": { + "shared": true, + "sort": 0, + "value_type": "individual" + }, + "type": "graph", + "xaxis": { + "buckets": null, + "mode": "time", + "name": null, + "show": true, + "values": [] + }, + "yaxes": [ + { + "format": "short", + "label": "", + "logBase": 1, + "max": "100", + "min": "0", + "show": true + }, + { + "format": "short", + "label": "", + "logBase": 1, + "max": null, + "min": null, + "show": true + } + ], + "yaxis": { + "align": false, + "alignLevel": null + } } ], - "schemaVersion": 18, + "schemaVersion": 31, "style": "dark", "tags": [], "templating": { @@ -984,25 +1218,29 @@ { "allValue": null, "current": { - "tags": [], - "text": "default", - "value": "default" + "selected": true, + "text": "wire-a", + "value": "wire-a" }, "datasource": "Prometheus", "definition": "kube_namespace_labels", + "description": null, + "error": null, "hide": 0, "includeAll": true, "label": null, "multi": false, "name": "namespace", "options": [], - "query": "kube_namespace_labels", - "refresh": 0, + "query": { + "query": "kube_namespace_labels", + "refId": "Prometheus-namespace-Variable-Query" + }, + "refresh": 1, "regex": "/namespace=\"([^\"]+)\"/", "skipUrlSync": false, "sort": 0, "tagValuesQuery": "", - "tags": [], "tagsQuery": "", "type": "query", "useTags": false @@ -1010,7 +1248,7 @@ ] }, "time": { - "from": "now-6h", + "from": "now-1h", "to": "now" }, "timepicker": { @@ -1041,5 +1279,5 @@ "timezone": "", "title": "Message Stats", "uid": "sqSUztzZz", - "version": 5 + "version": 1 } diff --git a/charts/wire-server-metrics/dashboards/services.json b/charts/wire-server-metrics/dashboards/services.json index 30bc06c349f..23d1111f028 100644 --- a/charts/wire-server-metrics/dashboards/services.json +++ b/charts/wire-server-metrics/dashboards/services.json @@ -8,28 +8,39 @@ "hide": true, "iconColor": "rgba(0, 211, 255, 1)", "name": "Annotations & Alerts", + "target": { + "limit": 100, + "matchAny": false, + "tags": [], + "type": "dashboard" + }, "type": "dashboard" } ] }, "editable": true, + "fiscalYearStartMonth": 0, "gnetId": null, "graphTooltip": 0, - "id": 11, - "iteration": 1556873852486, + "iteration": 1636449155094, "links": [], + "liveNow": false, "panels": [ { - "content": "# Haskell Service Statistics\n## Change the $(service) and $(namespace) variables to filter stats", + "datasource": null, "gridPos": { - "h": 3, + "h": 4, "w": 24, "x": 0, "y": 0 }, "id": 97, "links": [], - "mode": "markdown", + "options": { + "content": "# Haskell Service Statistics\n## Change the $(service) and $(namespace) variables to filter stats", + "mode": "markdown" + }, + "pluginVersion": "8.2.3", "timeFrom": null, "timeShift": null, "title": "README", @@ -38,11 +49,16 @@ }, { "collapsed": false, + "datasource": null, + "fieldConfig": { + "defaults": {}, + "overrides": [] + }, "gridPos": { "h": 1, "w": 24, "x": 0, - "y": 3 + "y": 4 }, "id": 89, "panels": [], @@ -54,13 +70,16 @@ "bars": true, "dashLength": 10, "dashes": false, + "datasource": null, "fill": 1, + "fillGradient": 0, "gridPos": { "h": 7, "w": 12, "x": 0, - "y": 4 + "y": 5 }, + "hiddenSeries": false, "id": 23, "legend": { "avg": false, @@ -75,8 +94,12 @@ "linewidth": 1, "links": [], "nullPointMode": "null", + "options": { + "alertThreshold": true + }, "paceLength": 10, "percentage": false, + "pluginVersion": "8.2.3", "pointradius": 2, "points": false, "renderer": "flot", @@ -86,8 +109,11 @@ "steppedLine": false, "targets": [ { + "exemplar": false, "expr": "sum(increase(http_request_duration_seconds_count{status_code=~\"5..\", namespace=\"$namespace\"}[5m])) by (role)", "format": "time_series", + "instant": false, + "interval": "", "intervalFactor": 5, "legendFormat": "{{role}}", "refId": "A" @@ -137,12 +163,13 @@ { "cacheTimeout": null, "columns": [], + "datasource": null, "fontSize": "100%", "gridPos": { "h": 7, "w": 12, "x": 12, - "y": 4 + "y": 5 }, "id": 98, "interval": "", @@ -157,12 +184,14 @@ "styles": [ { "alias": "Time", + "align": "auto", "dateFormat": "YYYY-MM-DD HH:mm:ss", "pattern": "Time", "type": "hidden" }, { "alias": "", + "align": "auto", "colorMode": null, "colors": [ "rgba(245, 54, 54, 0.9)", @@ -179,6 +208,7 @@ }, { "alias": "", + "align": "auto", "colorMode": null, "colors": [ "rgba(245, 54, 54, 0.9)", @@ -194,9 +224,11 @@ ], "targets": [ { + "exemplar": false, "expr": "sum(increase(http_request_duration_seconds_count{status_code=~\"5..\", namespace=\"$namespace\"}[$__range])) by (role, handler)", "format": "table", "instant": true, + "interval": "", "intervalFactor": 1, "legendFormat": "# 5XXs", "refId": "A" @@ -206,15 +238,20 @@ "timeShift": null, "title": "5XX/s per handler (current time range) - all services", "transform": "table", - "type": "table" + "type": "table-old" }, { "collapsed": false, + "datasource": null, + "fieldConfig": { + "defaults": {}, + "overrides": [] + }, "gridPos": { "h": 1, "w": 24, "x": 0, - "y": 11 + "y": 12 }, "id": 91, "panels": [], @@ -230,13 +267,16 @@ "bars": false, "dashLength": 10, "dashes": false, + "datasource": null, "fill": 4, + "fillGradient": 0, "gridPos": { "h": 8, "w": 12, "x": 0, - "y": 12 + "y": 13 }, + "hiddenSeries": false, "id": 18, "legend": { "avg": false, @@ -251,8 +291,12 @@ "linewidth": 1, "links": [], "nullPointMode": "null", + "options": { + "alertThreshold": true + }, "paceLength": 10, "percentage": false, + "pluginVersion": "8.2.3", "pointradius": 2, "points": false, "renderer": "flot", @@ -333,12 +377,13 @@ { "cacheTimeout": null, "columns": [], + "datasource": null, "fontSize": "100%", "gridPos": { "h": 8, "w": 6, "x": 12, - "y": 12 + "y": 13 }, "id": 20, "interval": "", @@ -353,12 +398,14 @@ "styles": [ { "alias": "Time", + "align": "auto", "dateFormat": "YYYY-MM-DD HH:mm:ss", "pattern": "Time", "type": "hidden" }, { "alias": "", + "align": "auto", "colorMode": null, "colors": [ "rgba(245, 54, 54, 0.9)", @@ -375,6 +422,7 @@ }, { "alias": "", + "align": "auto", "colorMode": null, "colors": [ "rgba(245, 54, 54, 0.9)", @@ -402,17 +450,18 @@ "timeShift": null, "title": "4XX/s per handler (current time range) - $service", "transform": "table", - "type": "table" + "type": "table-old" }, { "cacheTimeout": null, "columns": [], + "datasource": null, "fontSize": "100%", "gridPos": { "h": 8, "w": 6, "x": 18, - "y": 12 + "y": 13 }, "id": 21, "interval": "", @@ -427,12 +476,14 @@ "styles": [ { "alias": "Time", + "align": "auto", "dateFormat": "YYYY-MM-DD HH:mm:ss", "pattern": "Time", "type": "hidden" }, { "alias": "", + "align": "auto", "colorMode": null, "colors": [ "rgba(245, 54, 54, 0.9)", @@ -449,6 +500,7 @@ }, { "alias": "", + "align": "auto", "colorMode": null, "colors": [ "rgba(245, 54, 54, 0.9)", @@ -476,7 +528,7 @@ "timeShift": null, "title": "5XX/s per handler (current time range) - $service", "transform": "table", - "type": "table" + "type": "table-old" }, { "aliasColors": {}, @@ -487,13 +539,15 @@ "editable": true, "error": false, "fill": 2, + "fillGradient": 0, "grid": {}, "gridPos": { "h": 7, "w": 12, "x": 0, - "y": 20 + "y": 21 }, + "hiddenSeries": false, "id": 2, "legend": { "avg": false, @@ -508,8 +562,12 @@ "linewidth": 1, "links": [], "nullPointMode": "connected", + "options": { + "alertThreshold": true + }, "paceLength": 10, "percentage": false, + "pluginVersion": "8.2.3", "pointradius": 5, "points": false, "renderer": "flot", @@ -519,9 +577,11 @@ "steppedLine": false, "targets": [ { - "expr": "sum(rate(container_network_receive_bytes_total{pod_name=~\"$service.*\", namespace=\"$namespace\"}[5m])) by (pod_name)", + "exemplar": true, + "expr": "sum(rate(container_network_receive_bytes_total{pod=~\"$service.*\", namespace=\"$namespace\"}[5m])) by (pod_name)", "format": "time_series", "hide": false, + "interval": "", "intervalFactor": 2, "legendFormat": "{{pod_name}}", "refId": "A", @@ -571,11 +631,16 @@ }, { "collapsed": false, + "datasource": null, + "fieldConfig": { + "defaults": {}, + "overrides": [] + }, "gridPos": { "h": 1, "w": 24, "x": 0, - "y": 27 + "y": 28 }, "id": 27, "panels": [], @@ -592,13 +657,15 @@ "editable": true, "error": false, "fill": 2, + "fillGradient": 0, "grid": {}, "gridPos": { "h": 6, "w": 12, "x": 0, - "y": 28 + "y": 29 }, + "hiddenSeries": false, "id": 4, "legend": { "avg": false, @@ -613,8 +680,12 @@ "linewidth": 1, "links": [], "nullPointMode": "connected", + "options": { + "alertThreshold": true + }, "paceLength": 10, "percentage": false, + "pluginVersion": "8.2.3", "pointradius": 5, "points": false, "renderer": "flot", @@ -624,10 +695,12 @@ "steppedLine": false, "targets": [ { - "expr": "sum(container_cpu_load_average_10s{pod_name=~\"$service.*\", namespace=\"$namespace\"}) by (pod_name) * 100", + "exemplar": true, + "expr": "sum(container_cpu_load_average_10s{pod=~\"$service.*\", namespace=\"$namespace\"}) by (pod_name) * 100", "format": "time_series", "hide": false, "instant": false, + "interval": "", "intervalFactor": 2, "legendFormat": "{{ pod_name }}", "refId": "B", @@ -685,13 +758,15 @@ "editable": true, "error": false, "fill": 1, + "fillGradient": 0, "grid": {}, "gridPos": { "h": 6, "w": 12, "x": 12, - "y": 28 + "y": 29 }, + "hiddenSeries": false, "id": 5, "legend": { "avg": false, @@ -708,8 +783,12 @@ "linewidth": 1, "links": [], "nullPointMode": "connected", + "options": { + "alertThreshold": true + }, "paceLength": 10, "percentage": true, + "pluginVersion": "8.2.3", "pointradius": 5, "points": false, "renderer": "flot", @@ -728,7 +807,8 @@ "steppedLine": false, "targets": [ { - "expr": "sum(container_memory_usage_bytes{namespace=\"$namespace\", pod_name=~\"$service.*\", namespace=\"$namespace\"}) by (pod_name) / (1024 * 1024)", + "exemplar": true, + "expr": "sum(container_memory_usage_bytes{namespace=\"$namespace\", pod=~\"$service.*\", namespace=\"$namespace\"}) by (pod_name) / (1024 * 1024)", "format": "time_series", "hide": false, "interval": "", @@ -737,18 +817,6 @@ "refId": "A", "step": 2400, "target": "alias(scale(averageSeries(gundeck.*.eu-west-1.compute.internal.memory.memory.used), 0.000001), 'used')" - }, - { - "expr": "sum(container_spec_memory_limit_bytes{namespace=\"staging\", pod_name=~\"brig.*\", namespace=\"$namespace\"}) / (1024 * 1024)", - "format": "time_series", - "hide": true, - "instant": false, - "intervalFactor": 2, - "legendFormat": "Memory Limit (MB)", - "metric": "", - "refId": "C", - "step": 2400, - "target": "alias(scale(averageSeries(gundeck.*.eu-west-1.compute.internal.memory.memory.used), 0.000001), 'used')" } ], "thresholds": [], @@ -799,12 +867,14 @@ "dashes": false, "datasource": "default", "fill": 2, + "fillGradient": 0, "gridPos": { "h": 8, "w": 12, "x": 0, - "y": 34 + "y": 35 }, + "hiddenSeries": false, "id": 25, "legend": { "avg": false, @@ -819,8 +889,12 @@ "linewidth": 1, "links": [], "nullPointMode": "null", + "options": { + "alertThreshold": true + }, "paceLength": 10, "percentage": false, + "pluginVersion": "8.2.3", "pointradius": 2, "points": false, "renderer": "flot", @@ -880,7 +954,7 @@ } ], "refresh": false, - "schemaVersion": 18, + "schemaVersion": 31, "style": "dark", "tags": [], "templating": { @@ -888,10 +962,12 @@ { "allValue": null, "current": { - "tags": [], + "selected": true, "text": "brig", "value": "brig" }, + "description": null, + "error": null, "hide": 0, "includeAll": false, "label": "service", @@ -899,7 +975,7 @@ "name": "service", "options": [ { - "selected": false, + "selected": true, "text": "brig", "value": "brig" }, @@ -929,36 +1005,47 @@ "value": "spar" }, { - "selected": true, + "selected": false, "text": "proxy", "value": "proxy" + }, + { + "selected": false, + "text": "federator", + "value": "federator" } ], - "query": "brig,galley,cannon,gundeck,cargohold,spar,proxy", + "query": "brig,galley,cannon,gundeck,cargohold,spar,proxy,federator", + "queryValue": "", "skipUrlSync": false, "type": "custom" }, { "allValue": null, "current": { - "text": "staging", - "value": "staging" + "selected": true, + "text": "wire-a", + "value": "wire-a" }, "datasource": "Prometheus", "definition": "kube_namespace_labels", + "description": null, + "error": null, "hide": 0, "includeAll": true, "label": null, "multi": false, "name": "namespace", "options": [], - "query": "kube_namespace_labels", + "query": { + "query": "kube_namespace_labels", + "refId": "Prometheus-namespace-Variable-Query" + }, "refresh": 1, "regex": "/namespace=\"([^\"]+)\"/", "skipUrlSync": false, "sort": 0, "tagValuesQuery": "", - "tags": [], "tagsQuery": "", "type": "query", "useTags": false @@ -966,7 +1053,7 @@ ] }, "time": { - "from": "now-24h", + "from": "now-30m", "to": "now" }, "timepicker": { @@ -1003,5 +1090,5 @@ "timezone": "browser", "title": "Wire Services", "uid": "000000043", - "version": 17 -} \ No newline at end of file + "version": 1 +} diff --git a/charts/wire-server-metrics/requirements.yaml b/charts/wire-server-metrics/requirements.yaml index 90617e0eab2..5b7925e3e14 100644 --- a/charts/wire-server-metrics/requirements.yaml +++ b/charts/wire-server-metrics/requirements.yaml @@ -1,6 +1,6 @@ --- dependencies: - - name: prometheus-operator - version: 6.7.2 - repository: https://charts.helm.sh/stable + - name: kube-prometheus-stack + version: 19.2.3 + repository: https://prometheus-community.github.io/helm-charts diff --git a/charts/wire-server-metrics/templates/wire-server-dashboards.yaml b/charts/wire-server-metrics/templates/wire-server-dashboards.yaml new file mode 100644 index 00000000000..6be08a4def2 --- /dev/null +++ b/charts/wire-server-metrics/templates/wire-server-dashboards.yaml @@ -0,0 +1,23 @@ +{{- $files := .Files.Glob "dashboards/*.json" }} +{{- $relName := .Release.Name }} +{{- $namespace := .Release.Namespace }} +{{- if $files }} +apiVersion: v1 +kind: ConfigMapList +items: +{{- range $path, $fileContents := $files }} +{{- $dashboardName := regexReplaceAll "(^.*/)(.*)\\.json$" $path "${2}" }} +- apiVersion: v1 + kind: ConfigMap + metadata: + name: {{ printf "%s-%s" $relName $dashboardName | trunc 63 | trimSuffix "-" }} + namespace: {{ $namespace }} + labels: + {{- if index $.Values "kube-prometheus-stack" "grafana" "sidecar" "dashboards" "label" }} + {{ index $.Values "kube-prometheus-stack" "grafana" "sidecar" "dashboards" "label" }}: "1" + {{- end }} + app: {{ $.Release.Namespace }}-grafana + data: + {{ $dashboardName }}.json: {{ $.Files.Get $path | toJson }} +{{- end }} +{{- end }} diff --git a/charts/wire-server-metrics/values.yaml b/charts/wire-server-metrics/values.yaml index 37cbc3785d1..44bac846a35 100644 --- a/charts/wire-server-metrics/values.yaml +++ b/charts/wire-server-metrics/values.yaml @@ -1,4 +1,4 @@ -prometheus-operator: +kube-prometheus-stack: prometheus: additionalServiceMonitors: - name: wire-services @@ -38,29 +38,9 @@ prometheus-operator: enabled: true accessModes: ["ReadWriteOnce"] size: 10Gi - - dashboardProviders: - dashboardproviders.yaml: - apiVersion: 1 - providers: - - name: 'default' - orgId: 1 - folder: '' - type: file - disableDeletion: false - editable: true - options: - path: /var/lib/grafana/dashboards/default - - dashboards: - default: - # grafana can only access files from within its own chart directory - # which we don't have access to here; we can either dump the json - # directly into the values file, or load from a url - messages: - url: https://raw.githubusercontent.com/wireapp/wire-server-deploy/master/charts/wire-server-metrics/dashboards/message-stats.json - services: - url: https://raw.githubusercontent.com/wireapp/wire-server-deploy/master/charts/wire-server-metrics/dashboards/services.json + sidecar: + dashboards: + label: grafana_dashboard prometheusSpec: storageSpec: From 5aad6f62e808dfb686cc47baf2e78c77ef0b5cc6 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Wed, 17 Nov 2021 16:14:18 +0100 Subject: [PATCH 06/28] Handle Galley errors in federation RPCs (#1928) * Handle Galley errors in federation RPCs Return errors as part of the response of the leave-conversation RPC. This commit also simplifies the response type considerably, by limiting constructors to one per possible error type. It also replaces error responses in the public API handler with `CanThrow`. * Test propagation of leave-conv RPC failures * Test failure cases of leave-conversation RPC --- .../handle-leave-conversation-errors | 1 + .../src/Wire/API/Federation/API/Galley.hs | 11 ++- .../Wire/API/Federation/Golden/GoldenSpec.hs | 4 - .../Golden/LeaveConversationResponse.hs | 15 +--- ...testObject_LeaveConversationResponse4.json | 3 - ...testObject_LeaveConversationResponse5.json | 3 - ...testObject_LeaveConversationResponse6.json | 3 - ...testObject_LeaveConversationResponse7.json | 3 - .../wire-api/src/Wire/API/ErrorDescription.hs | 6 -- .../src/Wire/API/Routes/Public/Galley.hs | 26 +++--- .../API/Routes/Public/Galley/Responses.hs | 90 ------------------- libs/wire-api/wire-api.cabal | 3 +- services/galley/src/Galley/API/Federation.hs | 17 ++-- services/galley/src/Galley/API/Update.hs | 62 ++++++++----- services/galley/test/integration/API.hs | 54 +++++++++++ .../galley/test/integration/API/Federation.hs | 47 ++++++++++ 16 files changed, 180 insertions(+), 168 deletions(-) create mode 100644 changelog.d/6-federation/handle-leave-conversation-errors delete mode 100644 libs/wire-api-federation/test/golden/testObject_LeaveConversationResponse4.json delete mode 100644 libs/wire-api-federation/test/golden/testObject_LeaveConversationResponse5.json delete mode 100644 libs/wire-api-federation/test/golden/testObject_LeaveConversationResponse6.json delete mode 100644 libs/wire-api-federation/test/golden/testObject_LeaveConversationResponse7.json delete mode 100644 libs/wire-api/src/Wire/API/Routes/Public/Galley/Responses.hs diff --git a/changelog.d/6-federation/handle-leave-conversation-errors b/changelog.d/6-federation/handle-leave-conversation-errors new file mode 100644 index 00000000000..f6a0652966e --- /dev/null +++ b/changelog.d/6-federation/handle-leave-conversation-errors @@ -0,0 +1 @@ +Errors when leaving a conversation are now correctly handled instead of resulting in a generic federation error. diff --git a/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs b/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs index 6e258cc242c..47a7b928dee 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs @@ -45,7 +45,6 @@ import Wire.API.Federation.Client (FederationClientFailure, FederatorClient) import Wire.API.Federation.Domain (OriginDomainHeader) import qualified Wire.API.Federation.GRPC.Types as Proto import Wire.API.Message (MessageNotSent, MessageSendingStatus, PostOtrResponse, Priority) -import Wire.API.Routes.Public.Galley.Responses (RemoveFromConversationError) import Wire.API.User.Client (UserClientMap) import Wire.API.Util.Aeson (CustomEncoded (..)) @@ -214,6 +213,16 @@ data LeaveConversationRequest = LeaveConversationRequest deriving stock (Generic, Eq, Show) deriving (ToJSON, FromJSON) via (CustomEncoded LeaveConversationRequest) +-- | Error outcomes of the leave-conversation RPC. +data RemoveFromConversationError + = RemoveFromConversationErrorRemovalNotAllowed + | RemoveFromConversationErrorNotFound + | RemoveFromConversationErrorUnchanged + deriving stock (Eq, Show, Generic) + deriving + (ToJSON, FromJSON) + via (CustomEncoded RemoveFromConversationError) + -- Note: this is parametric in the conversation type to allow it to be used -- both for conversations with a fixed known domain (e.g. as the argument of the -- federation RPC), and for conversations with an arbitrary Qualified or Remote id diff --git a/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/GoldenSpec.hs b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/GoldenSpec.hs index 5cac536c68e..0c292d0756d 100644 --- a/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/GoldenSpec.hs +++ b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/GoldenSpec.hs @@ -47,10 +47,6 @@ spec = [ (LeaveConversationResponse.testObject_LeaveConversationResponse1, "testObject_LeaveConversationResponse1.json"), (LeaveConversationResponse.testObject_LeaveConversationResponse2, "testObject_LeaveConversationResponse2.json"), (LeaveConversationResponse.testObject_LeaveConversationResponse3, "testObject_LeaveConversationResponse3.json"), - (LeaveConversationResponse.testObject_LeaveConversationResponse4, "testObject_LeaveConversationResponse4.json"), - (LeaveConversationResponse.testObject_LeaveConversationResponse5, "testObject_LeaveConversationResponse5.json"), - (LeaveConversationResponse.testObject_LeaveConversationResponse6, "testObject_LeaveConversationResponse6.json"), - (LeaveConversationResponse.testObject_LeaveConversationResponse7, "testObject_LeaveConversationResponse7.json"), (LeaveConversationResponse.testObject_LeaveConversationResponse8, "testObject_LeaveConversationResponse8.json") ] testObjects diff --git a/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/LeaveConversationResponse.hs b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/LeaveConversationResponse.hs index 5010d274794..28044c95f62 100644 --- a/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/LeaveConversationResponse.hs +++ b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/LeaveConversationResponse.hs @@ -1,8 +1,7 @@ module Test.Wire.API.Federation.Golden.LeaveConversationResponse where import Imports -import Wire.API.Federation.API.Galley (LeaveConversationResponse (LeaveConversationResponse)) -import Wire.API.Routes.Public.Galley.Responses (RemoveFromConversationError (..)) +import Wire.API.Federation.API.Galley testObject_LeaveConversationResponse1 :: LeaveConversationResponse testObject_LeaveConversationResponse1 = LeaveConversationResponse $ Right () @@ -13,17 +12,5 @@ testObject_LeaveConversationResponse2 = LeaveConversationResponse $ Left RemoveF testObject_LeaveConversationResponse3 :: LeaveConversationResponse testObject_LeaveConversationResponse3 = LeaveConversationResponse $ Left RemoveFromConversationErrorNotFound -testObject_LeaveConversationResponse4 :: LeaveConversationResponse -testObject_LeaveConversationResponse4 = LeaveConversationResponse $ Left RemoveFromConversationErrorCustomRolesNotSupported - -testObject_LeaveConversationResponse5 :: LeaveConversationResponse -testObject_LeaveConversationResponse5 = LeaveConversationResponse $ Left RemoveFromConversationErrorSelfConv - -testObject_LeaveConversationResponse6 :: LeaveConversationResponse -testObject_LeaveConversationResponse6 = LeaveConversationResponse $ Left RemoveFromConversationErrorOne2OneConv - -testObject_LeaveConversationResponse7 :: LeaveConversationResponse -testObject_LeaveConversationResponse7 = LeaveConversationResponse $ Left RemoveFromConversationErrorConnectConv - testObject_LeaveConversationResponse8 :: LeaveConversationResponse testObject_LeaveConversationResponse8 = LeaveConversationResponse $ Left RemoveFromConversationErrorUnchanged diff --git a/libs/wire-api-federation/test/golden/testObject_LeaveConversationResponse4.json b/libs/wire-api-federation/test/golden/testObject_LeaveConversationResponse4.json deleted file mode 100644 index fcfcc05ae7c..00000000000 --- a/libs/wire-api-federation/test/golden/testObject_LeaveConversationResponse4.json +++ /dev/null @@ -1,3 +0,0 @@ -{ - "Left": "RemoveFromConversationErrorCustomRolesNotSupported" -} \ No newline at end of file diff --git a/libs/wire-api-federation/test/golden/testObject_LeaveConversationResponse5.json b/libs/wire-api-federation/test/golden/testObject_LeaveConversationResponse5.json deleted file mode 100644 index 13ebfa75124..00000000000 --- a/libs/wire-api-federation/test/golden/testObject_LeaveConversationResponse5.json +++ /dev/null @@ -1,3 +0,0 @@ -{ - "Left": "RemoveFromConversationErrorSelfConv" -} \ No newline at end of file diff --git a/libs/wire-api-federation/test/golden/testObject_LeaveConversationResponse6.json b/libs/wire-api-federation/test/golden/testObject_LeaveConversationResponse6.json deleted file mode 100644 index a67023bc523..00000000000 --- a/libs/wire-api-federation/test/golden/testObject_LeaveConversationResponse6.json +++ /dev/null @@ -1,3 +0,0 @@ -{ - "Left": "RemoveFromConversationErrorOne2OneConv" -} \ No newline at end of file diff --git a/libs/wire-api-federation/test/golden/testObject_LeaveConversationResponse7.json b/libs/wire-api-federation/test/golden/testObject_LeaveConversationResponse7.json deleted file mode 100644 index fd7bd4385c8..00000000000 --- a/libs/wire-api-federation/test/golden/testObject_LeaveConversationResponse7.json +++ /dev/null @@ -1,3 +0,0 @@ -{ - "Left": "RemoveFromConversationErrorConnectConv" -} \ No newline at end of file diff --git a/libs/wire-api/src/Wire/API/ErrorDescription.hs b/libs/wire-api/src/Wire/API/ErrorDescription.hs index ca896ff1462..f02a37cc0f0 100644 --- a/libs/wire-api/src/Wire/API/ErrorDescription.hs +++ b/libs/wire-api/src/Wire/API/ErrorDescription.hs @@ -294,12 +294,6 @@ type MissingLegalholdConsent = "Failed to connect to a user or to invite a user to a group because somebody \ \is under legalhold and somebody else has not granted consent." -type CustomRolesNotSupported = - ErrorDescription - 400 - "bad-request" - "Custom roles not supported" - type InvalidOp desc = ErrorDescription 403 diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs b/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs index 20e2e00db2b..7aafbfa7bf7 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs @@ -39,7 +39,6 @@ import Wire.API.Event.Conversation import Wire.API.Message import Wire.API.Routes.MultiVerb import Wire.API.Routes.Public -import Wire.API.Routes.Public.Galley.Responses import Wire.API.Routes.Public.Util import Wire.API.Routes.QualifiedCapture import Wire.API.ServantProto (Proto, RawProto) @@ -72,6 +71,15 @@ type ConversationVerb = type ConvUpdateResponses = UpdateResponses "Conversation unchanged" "Conversation updated" Event +type RemoveFromConversationVerb = + MultiVerb + 'DELETE + '[JSON] + '[ RespondEmpty 204 "No change", + Respond 200 "Member removed" Event + ] + (Maybe Event) + data Api routes = Api { -- Conversations @@ -258,15 +266,13 @@ data Api routes = Api :- Summary "Remove a member from a conversation (deprecated)" :> ZLocalUser :> ZConn + :> CanThrow ConvNotFound + :> CanThrow (InvalidOp "Invalid operation") :> "conversations" :> Capture' '[Description "Conversation ID"] "cnv" ConvId :> "members" :> Capture' '[Description "Target User ID"] "usr" UserId - :> MultiVerb - 'DELETE - '[JSON] - RemoveFromConversationHTTPResponse - RemoveFromConversationResponse, + :> RemoveFromConversationVerb, -- This endpoint can lead to the following events being sent: -- - MemberLeave event to members removeMember :: @@ -274,15 +280,13 @@ data Api routes = Api :- Summary "Remove a member from a conversation" :> ZLocalUser :> ZConn + :> CanThrow ConvNotFound + :> CanThrow (InvalidOp "Invalid operation") :> "conversations" :> QualifiedCapture' '[Description "Conversation ID"] "cnv" ConvId :> "members" :> QualifiedCapture' '[Description "Target User ID"] "usr" UserId - :> MultiVerb - 'DELETE - '[JSON] - RemoveFromConversationHTTPResponse - RemoveFromConversationResponse, + :> RemoveFromConversationVerb, -- This endpoint can lead to the following events being sent: -- - MemberStateUpdate event to members updateOtherMemberUnqualified :: diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Galley/Responses.hs b/libs/wire-api/src/Wire/API/Routes/Public/Galley/Responses.hs deleted file mode 100644 index 697cea76164..00000000000 --- a/libs/wire-api/src/Wire/API/Routes/Public/Galley/Responses.hs +++ /dev/null @@ -1,90 +0,0 @@ --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2021 Wire Swiss GmbH --- --- 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 . - --- | The module provides Galley HTTP response types and corresponding handler --- types. -module Wire.API.Routes.Public.Galley.Responses where - -import Data.Aeson (FromJSON, ToJSON) -import Data.SOP (I (..), NS (..), unI, unZ) -import qualified Generics.SOP as GSOP -import Imports -import Servant (type (.++)) -import Wire.API.ErrorDescription - ( ConvMemberRemovalDenied, - ConvNotFound, - CustomRolesNotSupported, - InvalidOpConnectConv, - InvalidOpOne2OneConv, - InvalidOpSelfConv, - ) -import qualified Wire.API.Event.Conversation as Public -import Wire.API.Routes.MultiVerb (AsUnion (..), GenericAsUnion (..), Respond, RespondEmpty, ResponseType, eitherFromUnion, eitherToUnion) -import Wire.API.Util.Aeson (CustomEncoded (CustomEncoded)) - --- | These are just the "error" outcomes of the 'RemoveFromConversationResponses' type. --- This is needed in using ExceptT to differentiate error outcomes from an --- outcome reflecting a change. -data RemoveFromConversationError - = RemoveFromConversationErrorRemovalNotAllowed - | RemoveFromConversationErrorNotFound - | RemoveFromConversationErrorCustomRolesNotSupported - | RemoveFromConversationErrorSelfConv - | RemoveFromConversationErrorOne2OneConv - | RemoveFromConversationErrorConnectConv - | RemoveFromConversationErrorUnchanged - deriving stock (Eq, Show, Generic) - deriving - (ToJSON, FromJSON) - via (CustomEncoded RemoveFromConversationError) - deriving - (AsUnion RemovalNotPerformedHTTPResponses) - via (GenericAsUnion RemovalNotPerformedHTTPResponses RemoveFromConversationError) - -instance GSOP.Generic RemoveFromConversationError - -type RemovalNotPerformedHTTPResponses = - '[ ConvMemberRemovalDenied, - ConvNotFound, - CustomRolesNotSupported, - InvalidOpSelfConv, - InvalidOpOne2OneConv, - InvalidOpConnectConv, - RespondEmpty 204 "No change" - ] - -type RemoveFromConversationHTTPResponse = - RemovalNotPerformedHTTPResponses - .++ '[Respond 200 "Member removed" Public.Event] - -type RemoveFromConversationResponse = Either RemoveFromConversationError Public.Event - -instance - ( rs ~ (RemovalNotPerformedHTTPResponses .++ '[r]), - Public.Event ~ ResponseType r - ) => - AsUnion rs RemoveFromConversationResponse - where - toUnion = - eitherToUnion - (toUnion @RemovalNotPerformedHTTPResponses) - (Z . I) - - fromUnion = - eitherFromUnion - (fromUnion @RemovalNotPerformedHTTPResponses) - (unI . unZ) diff --git a/libs/wire-api/wire-api.cabal b/libs/wire-api/wire-api.cabal index 0b9c20d7dc2..ccb35be4219 100644 --- a/libs/wire-api/wire-api.cabal +++ b/libs/wire-api/wire-api.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: f7a6c4eafbaab04b23ffb79fcde736cd8d0894f91c6ef1eace2de5b98d9a47e5 +-- hash: fff87c53181cb0f2cd21a3da254e2a9a5dbae2ee00ea67ac124be1593a640e5e name: wire-api version: 0.1.0 @@ -58,7 +58,6 @@ library Wire.API.Routes.Public Wire.API.Routes.Public.Brig Wire.API.Routes.Public.Galley - Wire.API.Routes.Public.Galley.Responses Wire.API.Routes.Public.LegalHold Wire.API.Routes.Public.Spar Wire.API.Routes.Public.Util diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index f1527638646..155a0f7e1de 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -63,7 +63,6 @@ import Wire.API.Event.Conversation import Wire.API.Federation.API.Common (EmptyResponse (..)) import qualified Wire.API.Federation.API.Galley as F import Wire.API.Routes.Internal.Brig.Connection -import Wire.API.Routes.Public.Galley.Responses import Wire.API.ServantProto import Wire.API.User.Client (userClientMap) @@ -232,12 +231,9 @@ addLocalUsersToRemoteConv remoteConvId qAdder localUsers = do E.createMembersInRemoteConversation remoteConvId connectedList pure connected --- FUTUREWORK: actually return errors as part of the response instead of throwing leaveConversation :: Members '[ ConversationStore, - Error ActionError, - Error ConversationError, Error InvalidInput, ExternalAccess, FederatorAccess, @@ -255,12 +251,23 @@ leaveConversation requestingDomain lc = do lcnv <- qualifyLocal (F.lcConvId lc) fmap F.LeaveConversationResponse . runError - . mapError @NoChanges (const RemoveFromConversationErrorUnchanged) + . mapError handleNoChanges + . mapError handleConvError + . mapError handleActionError . void . updateLocalConversation lcnv leaver Nothing . ConversationLeave . pure $ leaver + where + handleConvError :: ConversationError -> F.RemoveFromConversationError + handleConvError _ = F.RemoveFromConversationErrorNotFound + + handleActionError :: ActionError -> F.RemoveFromConversationError + handleActionError _ = F.RemoveFromConversationErrorRemovalNotAllowed + + handleNoChanges :: NoChanges -> F.RemoveFromConversationError + handleNoChanges _ = F.RemoveFromConversationErrorUnchanged -- FUTUREWORK: report errors to the originating backend -- FUTUREWORK: error handling for missing / mismatched clients diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index af64045f7b6..1deea13837c 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -69,7 +69,6 @@ import Control.Error.Util (hush) import Control.Lens import Control.Monad.State import Data.Code -import Data.Either.Extra (mapRight) import Data.Id import Data.Json.Util (fromBase64TextLenient, toUTCTimeMillis) import Data.List1 @@ -127,7 +126,6 @@ import qualified Wire.API.Event.Conversation as Public import qualified Wire.API.Federation.API.Galley as FederatedGalley import Wire.API.Federation.Client import qualified Wire.API.Message as Public -import Wire.API.Routes.Public.Galley.Responses import Wire.API.Routes.Public.Util (UpdateResult (..)) import Wire.API.ServantProto (RawProto (..)) import Wire.API.User.Client @@ -1053,7 +1051,7 @@ removeMemberUnqualified :: ConnId -> ConvId -> UserId -> - Sem r RemoveFromConversationResponse + Sem r (Maybe Event) removeMemberUnqualified lusr con cnv victim = do let lvictim = qualifyAs lusr victim lcnv = qualifyAs lusr cnv @@ -1076,18 +1074,26 @@ removeMemberQualified :: ConnId -> Qualified ConvId -> Qualified UserId -> - Sem r RemoveFromConversationResponse -removeMemberQualified lusr con qcnv victim = do - foldQualified lusr removeMemberFromLocalConv removeMemberFromRemoteConv qcnv lusr (Just con) victim + Sem r (Maybe Event) +removeMemberQualified lusr con = + foldQualified + lusr + (\lcnv -> removeMemberFromLocalConv lcnv lusr (Just con)) + (\rcnv -> removeMemberFromRemoteConv rcnv lusr) removeMemberFromRemoteConv :: - Members '[FederatorAccess, Input UTCTime] r => + Members + '[ FederatorAccess, + Error ActionError, + Error ConversationError, + Input UTCTime + ] + r => Remote ConvId -> Local UserId -> - Maybe ConnId -> Qualified UserId -> - Sem r RemoveFromConversationResponse -removeMemberFromRemoteConv cnv lusr _ victim + Sem r (Maybe Event) +removeMemberFromRemoteConv cnv lusr victim | qUntagged lusr == victim = do let lc = FederatedGalley.LeaveConversationRequest (tUnqualified cnv) (qUnqualified victim) let rpc = @@ -1095,13 +1101,25 @@ removeMemberFromRemoteConv cnv lusr _ victim FederatedGalley.clientRoutes (qDomain victim) lc - t <- input - let successEvent = - Event MemberLeave (qUntagged cnv) (qUntagged lusr) t $ - EdMembersLeave (QualifiedUserIdList [victim]) - mapRight (const successEvent) . FederatedGalley.leaveResponse - <$> E.runFederated cnv rpc - | otherwise = pure . Left $ RemoveFromConversationErrorRemovalNotAllowed + (either handleError handleSuccess =<<) . fmap FederatedGalley.leaveResponse $ + E.runFederated cnv rpc + | otherwise = throw (ActionDenied RemoveConversationMember) + where + handleError :: + Members '[Error ActionError, Error ConversationError] r => + FederatedGalley.RemoveFromConversationError -> + Sem r (Maybe Event) + handleError FederatedGalley.RemoveFromConversationErrorRemovalNotAllowed = + throw (ActionDenied RemoveConversationMember) + handleError FederatedGalley.RemoveFromConversationErrorNotFound = throw ConvNotFound + handleError FederatedGalley.RemoveFromConversationErrorUnchanged = pure Nothing + + handleSuccess :: Member (Input UTCTime) r => () -> Sem r (Maybe Event) + handleSuccess _ = do + t <- input + pure . Just $ + Event MemberLeave (qUntagged cnv) (qUntagged lusr) t $ + EdMembersLeave (QualifiedUserIdList [victim]) -- | Remove a member from a local conversation. removeMemberFromLocalConv :: @@ -1121,15 +1139,13 @@ removeMemberFromLocalConv :: Local UserId -> Maybe ConnId -> Qualified UserId -> - Sem r RemoveFromConversationResponse -removeMemberFromLocalConv lcnv lusr con victim = - -- FUTUREWORK: actually return errors as part of the response instead of throwing - runError - . mapError @NoChanges (const (RemoveFromConversationErrorUnchanged)) + Sem r (Maybe Event) +removeMemberFromLocalConv lcnv lusr con = + fmap hush + . runError @NoChanges . updateLocalConversation lcnv (qUntagged lusr) con . ConversationLeave . pure - $ victim -- OTR diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index 40c5be5010f..945bda76de1 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -183,6 +183,8 @@ tests s = test s "delete conversations/:domain/:cnv/members/:domain/:usr - local conv with locals and remote, delete local" deleteLocalMemberConvLocalQualifiedOk, test s "delete conversations/:domain/:cnv/members/:domain/:usr - local conv with locals and remote, delete remote" deleteRemoteMemberConvLocalQualifiedOk, test s "delete conversations/:domain/:cnv/members/:domain/:usr - remote conv, leave conv" leaveRemoteConvQualifiedOk, + test s "delete conversations/:domain/:cnv/members/:domain/:usr - remote conv, leave conv, non-existent" leaveNonExistentRemoteConv, + test s "delete conversations/:domain/:cnv/members/:domain/:usr - remote conv, leave conv, denied" leaveRemoteConvDenied, test s "delete conversations/:domain/:cnv/members/:domain/:usr - remote conv, remove local user, fail" removeLocalMemberConvQualifiedFail, test s "delete conversations/:domain/:cnv/members/:domain/:usr - remote conv, remove remote user, fail" removeRemoteMemberConvQualifiedFail, test s "rename conversation (deprecated endpoint)" putConvDeprecatedRenameOk, @@ -2616,6 +2618,58 @@ leaveRemoteConvQualifiedOk = do FederatedGalley.lcConvId leaveRequest @?= conv FederatedGalley.lcLeaver leaveRequest @?= alice +-- Alice tries to leave a non-existent remote conversation +leaveNonExistentRemoteConv :: TestM () +leaveNonExistentRemoteConv = do + alice <- randomQualifiedUser + let remoteDomain = Domain "faraway.example.com" + conv <- randomQualifiedId remoteDomain + + let mockResponses :: F.FederatedRequest -> Maybe Value + mockResponses req + | fmap F.component (F.request req) == Just F.Galley = + Just . toJSON . FederatedGalley.LeaveConversationResponse $ + Left FederatedGalley.RemoveFromConversationErrorNotFound + | otherwise = Nothing + + (resp, fedRequests) <- + withTempMockFederator mockResponses $ + responseJsonError =<< deleteMemberQualified (qUnqualified alice) alice conv + Maybe Value + mockResponses req + | fmap F.component (F.request req) == Just F.Galley = + Just . toJSON . FederatedGalley.LeaveConversationResponse $ + Left FederatedGalley.RemoveFromConversationErrorRemovalNotAllowed + | otherwise = Nothing + + (resp, fedRequests) <- + withTempMockFederator mockResponses $ + responseJsonError =<< deleteMemberQualified (qUnqualified alice) alice conv + randomQualifiedUser + + (bob, conv) <- generateRemoteAndConvIdWithDomain remoteDomain True alice + connectWithRemoteUser (tUnqualified alice) (qUntagged bob) + createOne2OneConvWithRemote alice bob + + g <- viewGalley + let leaveRequest = FedGalley.LeaveConversationRequest (qUnqualified conv) (tUnqualified bob) + resp <- + fmap FedGalley.leaveResponse $ + responseJsonError + =<< post + ( g + . paths ["federation", "leave-conversation"] + . content "application/json" + . header "Wire-Origin-Domain" (toByteString' remoteDomain) + . json leaveRequest + ) + Date: Wed, 17 Nov 2021 23:30:41 +0100 Subject: [PATCH 07/28] Changelog.d docs (#1934) * Add documentation of the changelog.d process. * Reference changelog.d-docs in PR template. Co-authored-by: jschaul --- .github/pull_request_template.md | 2 +- changelog.d/4-docs/changelog.d-docs | 1 + docs/developer/changelog.md | 41 +++++++++++++++++++++++++++++ 3 files changed, 43 insertions(+), 1 deletion(-) create mode 100644 changelog.d/4-docs/changelog.d-docs create mode 100644 docs/developer/changelog.md diff --git a/.github/pull_request_template.md b/.github/pull_request_template.md index e2699e8fa45..eee52d1ebcd 100644 --- a/.github/pull_request_template.md +++ b/.github/pull_request_template.md @@ -4,7 +4,7 @@ - [ ] The **PR description** provides context as to why the change should occur and what the code contributes to that effect. This could also be a link to a JIRA ticket or a Github issue, if there is one. - [ ] If HTTP endpoint paths have been added or renamed, the **endpoint / config-flag checklist** (see Wire-employee only backend [wiki page](https://github.com/zinfra/backend-wiki/wiki/Checklists)) has been followed. - [ ] If a cassandra schema migration has been added, I ran **`make git-add-cassandra-schema`** to update the cassandra schema documentation. - - [ ] **changelog.d** contains the following bits of information: + - [ ] **changelog.d** contains the following bits of information ([details](https://github.com/wireapp/wire-server/blob/develop/docs/developer/changelog.md)): - [ ] A file with the changelog entry in one or more suitable sub-sections. The sub-sections are marked by directories inside `changelog.d`. - [ ] If new config options introduced: added usage description under docs/reference/config-options.md - [ ] If new config options introduced: recommended measures to be taken by on-premise instance operators. diff --git a/changelog.d/4-docs/changelog.d-docs b/changelog.d/4-docs/changelog.d-docs new file mode 100644 index 00000000000..8308ed56ebb --- /dev/null +++ b/changelog.d/4-docs/changelog.d-docs @@ -0,0 +1 @@ +Document the wire-server PR process better. diff --git a/docs/developer/changelog.md b/docs/developer/changelog.md new file mode 100644 index 00000000000..886df37964a --- /dev/null +++ b/docs/developer/changelog.md @@ -0,0 +1,41 @@ +The wire-server repo has a process for changelog editing that prevents +merge conflicts and enforces a consistent structure to the release +notes. + +*Introduced in https://github.com/wireapp/wire-server/pull/1749.* + +## tl;dr + +Entries have to be written in individual files in a relevant subfolder of `./changelog.d/`. + +*Example*: create the file `./changelog.d/2-features/potato-peeler` with one-line contents `Introduce automatic potato peeler functionality when buying potatoes, see [docs](link-to-docs)` + +## Details + +On every pull request, one is supposed to create a new file in the +appropriate subdirectory of `changelog.d`, containing just the text of +the corresponding changelog entry. There is no need to explicitly +write a PR number, because the `mk-changelog.sh` script will add it +automatically at the end. The name of the file does not matter, but +please try to make it unique to avoid unnecessary conflicts (e.g. use +the branch name). + +It is still possible to write the PR number manually if so desired, +which is useful in case the entry should refer to multiple PRs. In +that case, the script leaves the PR number reference intact, as long +as it is at the very end of the entry (no period allowed afterwards!), +and in brackets. It is also possible to use the pattern `##` to refer +to the current PR number. This will be replaced throughout. + +Multiline entries are supported, and should be handled +correctly. Again, the PR reference should either be omitted or put at +the very end. If multiple entries for a single PR are desired, one +should create a different file for each of them. + +## Generating a CHANGELOG for a release + +Just run the script `changelog.d/mk-changelog.sh` with no +arguments. It will print all the entries, nicely formatted, on +standard output. The script gets PR numbers from the `git` log. If +that fails for any reason (e.g. if an entry was added outside of a +PR), make sure that the entry has a manually specified PR number. From 4f65bc0cf3c6db50ae56e50f2a497f8608d6c0b7 Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Fri, 19 Nov 2021 17:58:43 +0100 Subject: [PATCH 08/28] fix bug: itests wrong when there is no pattern (#1936) --- Makefile | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/Makefile b/Makefile index 09c4f5b6221..2bfa7e61fa1 100644 --- a/Makefile +++ b/Makefile @@ -69,7 +69,11 @@ endif # Usage: make ci package=brig test=1 .PHONY: ci ci: c +ifeq ("$(pattern)", "") + make -C services/$(package) i +else make -C services/$(package) i-$(pattern) +endif # Build everything (Haskell services and nginz) .PHONY: services From 50ee901eabf7abb9ac5fc493ee36f5183340397e Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Tue, 23 Nov 2021 08:47:38 -0800 Subject: [PATCH 09/28] Upgrade polysemy to v1.7.0.0 (#1932) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * Upgrade polysemy * changelog * Use polysemy-mocks fix PR here: https://github.com/akshaymankar/polysemy-mocks/pull/3 * Changes due to: cabal update && ./tools/convert-to-cabal/generate.sh * Use polysemy-mocks 0.2 * Retry CI * Hi CI Co-authored-by: Paolo Capriotti Co-authored-by: Marko Dimjašević Co-authored-by: Akshay Mankar --- cabal.project | 5 ++++ cabal.project.freeze | 6 ++--- changelog.d/5-internal/polysemy-1.7.0.0 | 2 ++ stack.yaml | 8 +++--- stack.yaml.lock | 36 ++++++++++++------------- 5 files changed, 32 insertions(+), 25 deletions(-) create mode 100644 changelog.d/5-internal/polysemy-1.7.0.0 diff --git a/cabal.project b/cabal.project index ef0d913ebad..b27da7ad1c5 100644 --- a/cabal.project +++ b/cabal.project @@ -148,6 +148,11 @@ source-repository-package tag: eea98418672626eafbace3181ca34bf44bee91c0 subdir: http2-client-grpc +source-repository-package + type: git + location: https://github.com/wireapp/polysemy-mocks + tag: 8f687140a218ec8cc9e466259600d3c5839ed185 + source-repository-package type: git location: https://github.com/wireapp/saml2-web-sso diff --git a/cabal.project.freeze b/cabal.project.freeze index 71ff635e0b6..bd2b1ba22d1 100644 --- a/cabal.project.freeze +++ b/cabal.project.freeze @@ -1701,9 +1701,9 @@ constraints: any.AC-Angle ==1.0, any.poly-arity ==0.1.0, any.polynomials-bernstein ==1.1.2, any.polyparse ==1.13, - any.polysemy ==1.6.0.0, - any.polysemy-mocks ==0.1.0.0, - any.polysemy-plugin ==0.2.5.2, + any.polysemy ==1.7.0.0, + any.polysemy-check ==0.8.1.0, + any.polysemy-plugin ==0.4.2.0, any.pooled-io ==0.0.2.2, any.port-utils ==0.2.1.0, any.posix-paths ==0.2.1.6, diff --git a/changelog.d/5-internal/polysemy-1.7.0.0 b/changelog.d/5-internal/polysemy-1.7.0.0 new file mode 100644 index 00000000000..5bc5396e594 --- /dev/null +++ b/changelog.d/5-internal/polysemy-1.7.0.0 @@ -0,0 +1,2 @@ +Upgrade to polysemy-1.7.0.0 + diff --git a/stack.yaml b/stack.yaml index 28cd4ee7aa4..6c4c22a8e36 100644 --- a/stack.yaml +++ b/stack.yaml @@ -144,7 +144,6 @@ extra-deps: - stm-hamt-1.2.0.4 # Latest: lts-15.16 - primitive-unlifted-0.1.2.0 # Latest: lts-15.16 - prometheus-2.2.2 # Only in nightly so far -- polysemy-plugin-0.2.5.2 # Latest: lts-14.27 # Not on stackage - currency-codes-3.0.0.1 @@ -162,9 +161,9 @@ extra-deps: - markov-chain-usage-model-0.0.0 - wai-predicates-1.0.0 - redis-io-1.1.0 -- polysemy-mocks-0.1.0.0 +- polysemy-mocks-0.2.0.0 -# Not latest as latst one breaks wai-routing +# Not latest as last one breaks wai-routing - wai-route-0.4.0 # Not updated on Stackage yet @@ -174,7 +173,6 @@ extra-deps: - servant-swagger-ui-0.3.4.3.36.1 - tls-1.5.5 - cryptonite-0.28 -- polysemy-1.6.0.0 # needed for Polysemy.Input combinators # For changes from #128 and #135, not released to hackage yet - git: https://github.com/haskell-servant/servant-swagger @@ -255,6 +253,8 @@ extra-deps: - x509-store # Not on stackage yet +- polysemy-1.7.0.0 +- polysemy-plugin-0.4.2.0 - polysemy-check-0.8.1.0 ############################################################ diff --git a/stack.yaml.lock b/stack.yaml.lock index 9c6dd2b653f..d830e30c3b3 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -342,13 +342,6 @@ packages: sha256: 3b1cb27cf8cb0a8da83b5730e85132e058e808f8dd1be349ea3dbb162c7f14c3 original: hackage: prometheus-2.2.2 -- completed: - hackage: polysemy-plugin-0.2.5.2@sha256:649cea55749c38af841e9f3750ccf65be351e597f3085234e28e3491e78d1f78,3155 - pantry-tree: - size: 1162 - sha256: 20b462f8095a8108ef4d920f0d494ba1299821403ad30169168f4b1968b06c2a - original: - hackage: polysemy-plugin-0.2.5.2 - completed: hackage: currency-codes-3.0.0.1@sha256:a4b24669dd91e805b11d9eb267becd0ba6d726927e535e03d5f3f368f44c1cf4,2902 pantry-tree: @@ -455,12 +448,12 @@ packages: original: hackage: redis-io-1.1.0 - completed: - hackage: polysemy-mocks-0.1.0.0@sha256:f2d7068e5cd74cfd1e34f23d15c2610f0a1608e0f0a02539f8d432a9971ad094,1426 + hackage: polysemy-mocks-0.2.0.0@sha256:ed7b4aa8ee29995d0b840ac0c131a141636ca46493b82706b7e5ec5e33b9ffa7,1441 pantry-tree: - size: 694 - sha256: 094dd07046b545e3bb81508d5faefc545719f2560415f66b8e1703902348fa23 + size: 695 + sha256: 8218e3dde278ca1f01d19009fad40f603e1b17993a519d15fe6319e3a827cc01 original: - hackage: polysemy-mocks-0.1.0.0 + hackage: polysemy-mocks-0.2.0.0 - completed: hackage: wai-route-0.4.0@sha256:ee52f13d2945e4a56147e91e515e184f840654f2e3d9071c73bec3d8aa1f4444,2119 pantry-tree: @@ -510,13 +503,6 @@ packages: sha256: 3737ee32d6629b4b915c01911fdb9dc0e255b96233799479c29420d986634726 original: hackage: cryptonite-0.28 -- completed: - hackage: polysemy-1.6.0.0@sha256:29a73b1bf3d0049b12041016b7ee25e76bd8f6e99f9c37c2dde2b46368246697,6184 - pantry-tree: - size: 4577 - sha256: c4ca508b4a6786fc27e0f484344ce8dba119ea2f7fe47fb7379a51313a94cd10 - original: - hackage: polysemy-1.6.0.0 - completed: name: servant-swagger version: 1.1.11 @@ -804,6 +790,20 @@ packages: subdir: x509-store git: https://github.com/vincenthz/hs-certificate commit: a899bda3d7666d25143be7be8f3105fc076703d9 +- completed: + hackage: polysemy-1.7.0.0@sha256:c972f33191113e2fe6809ea1cda24a6cabfeed2f115b3be0137dee7c65d08293,5977 + pantry-tree: + size: 4577 + sha256: 78c733f5dde13340e880bbb883dc64af948f6449da3a4025811cdc79c204dfde + original: + hackage: polysemy-1.7.0.0 +- completed: + hackage: polysemy-plugin-0.4.2.0@sha256:1dbcb892bb866926994dadafeb93e76ae4a6625dc3ae9ca0f4f419ee85cb2f7b,3154 + pantry-tree: + size: 1229 + sha256: ee75425b00b0f1c80207c3c4d5df86a94d892de229b75fb23e0380ec2526a626 + original: + hackage: polysemy-plugin-0.4.2.0 - completed: hackage: polysemy-check-0.8.1.0@sha256:5cce3ae162d2f8d8f629397daa28ec5e425f72d357afeb4fe994e102425f2383,2648 pantry-tree: From 341f7a1b8b53e915ca0f6648049539581c65685a Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Wed, 24 Nov 2021 14:56:06 -0800 Subject: [PATCH 10/28] Spar Polysemy: In-memory interpreters (#1920) * Now and AssIDStore interpreters * Add AReqIDStore.Mem * add boolTTL helper * Add BindCookieStore.Mem * Add SAMLUserStore.Mem * Make format * Add DefaultSsoCode.Mem * Add ScimExternalIdStore.Mem * Add ScimTokenStore.Mem * Add ScimUserTimesStore.Mem * make format * Changelog * Pull out VerdictFormatStore * Remove stale comment * Also emit internal state * Hi CI --- changelog.d/5-internal/in-mem-interpreters | 1 + libs/wire-api/src/Wire/API/Cookie.hs | 1 + libs/wire-api/src/Wire/API/User/Scim.hs | 2 +- services/spar/spar.cabal | 12 ++++++- services/spar/src/Spar/Sem/AReqIDStore/Mem.hs | 26 ++++++++++++++ services/spar/src/Spar/Sem/AssIDStore/Mem.hs | 25 ++++++++++++++ .../spar/src/Spar/Sem/BindCookieStore/Mem.hs | 28 +++++++++++++++ .../spar/src/Spar/Sem/DefaultSsoCode/Mem.hs | 16 +++++++++ services/spar/src/Spar/Sem/Now.hs | 14 ++++++++ services/spar/src/Spar/Sem/Now/Input.hs | 14 ++++++++ .../spar/src/Spar/Sem/SAMLUserStore/Mem.hs | 34 +++++++++++++++++++ .../src/Spar/Sem/ScimExternalIdStore/Mem.hs | 20 +++++++++++ .../spar/src/Spar/Sem/ScimTokenStore/Mem.hs | 21 ++++++++++++ .../spar/src/Spar/Sem/ScimUserTimesStore.hs | 2 +- .../src/Spar/Sem/ScimUserTimesStore/Mem.hs | 22 ++++++++++++ .../src/Spar/Sem/VerdictFormatStore/Mem.hs | 30 ++++++++++++++++ 16 files changed, 265 insertions(+), 3 deletions(-) create mode 100644 changelog.d/5-internal/in-mem-interpreters create mode 100644 services/spar/src/Spar/Sem/AReqIDStore/Mem.hs create mode 100644 services/spar/src/Spar/Sem/AssIDStore/Mem.hs create mode 100644 services/spar/src/Spar/Sem/BindCookieStore/Mem.hs create mode 100644 services/spar/src/Spar/Sem/DefaultSsoCode/Mem.hs create mode 100644 services/spar/src/Spar/Sem/Now/Input.hs create mode 100644 services/spar/src/Spar/Sem/SAMLUserStore/Mem.hs create mode 100644 services/spar/src/Spar/Sem/ScimExternalIdStore/Mem.hs create mode 100644 services/spar/src/Spar/Sem/ScimTokenStore/Mem.hs create mode 100644 services/spar/src/Spar/Sem/ScimUserTimesStore/Mem.hs create mode 100644 services/spar/src/Spar/Sem/VerdictFormatStore/Mem.hs diff --git a/changelog.d/5-internal/in-mem-interpreters b/changelog.d/5-internal/in-mem-interpreters new file mode 100644 index 00000000000..32d0dc0a454 --- /dev/null +++ b/changelog.d/5-internal/in-mem-interpreters @@ -0,0 +1 @@ +Add in-memory interpreters for most Spar effects diff --git a/libs/wire-api/src/Wire/API/Cookie.hs b/libs/wire-api/src/Wire/API/Cookie.hs index 6f42892d384..e77292ab4f6 100644 --- a/libs/wire-api/src/Wire/API/Cookie.hs +++ b/libs/wire-api/src/Wire/API/Cookie.hs @@ -36,6 +36,7 @@ instance ToParamSchema SetBindCookie where toParamSchema _ = toParamSchema (Proxy @String) newtype BindCookie = BindCookie {fromBindCookie :: ST} + deriving (Eq, Ord) instance ToParamSchema BindCookie where toParamSchema _ = toParamSchema (Proxy @String) diff --git a/libs/wire-api/src/Wire/API/User/Scim.hs b/libs/wire-api/src/Wire/API/User/Scim.hs index 7ae904573a2..8146ad0b0a1 100644 --- a/libs/wire-api/src/Wire/API/User/Scim.hs +++ b/libs/wire-api/src/Wire/API/User/Scim.hs @@ -108,7 +108,7 @@ userSchemas = -- -- For SCIM authentication and token handling logic, see "Spar.Scim.Auth". newtype ScimToken = ScimToken {fromScimToken :: Text} - deriving (Eq, Show, FromJSON, ToJSON, FromByteString, ToByteString) + deriving (Eq, Ord, Show, FromJSON, ToJSON, FromByteString, ToByteString) newtype ScimTokenHash = ScimTokenHash {fromScimTokenHash :: Text} deriving (Eq, Show) diff --git a/services/spar/spar.cabal b/services/spar/spar.cabal index f38adbaceea..a71562b0f42 100644 --- a/services/spar/spar.cabal +++ b/services/spar/spar.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: f787f064cceffbeeef6ac5c1ca7475e519a51afc3fdd173bf7a7a86a9016b238 +-- hash: 34138a2c7fa249191ae03bc1581a7c95c94b12080f104da084a9bc37ac54c9ad name: spar version: 0.1 @@ -38,14 +38,18 @@ library Spar.Scim.User Spar.Sem.AReqIDStore Spar.Sem.AReqIDStore.Cassandra + Spar.Sem.AReqIDStore.Mem Spar.Sem.AssIDStore Spar.Sem.AssIDStore.Cassandra + Spar.Sem.AssIDStore.Mem Spar.Sem.BindCookieStore Spar.Sem.BindCookieStore.Cassandra + Spar.Sem.BindCookieStore.Mem Spar.Sem.BrigAccess Spar.Sem.BrigAccess.Http Spar.Sem.DefaultSsoCode Spar.Sem.DefaultSsoCode.Cassandra + Spar.Sem.DefaultSsoCode.Mem Spar.Sem.GalleyAccess Spar.Sem.GalleyAccess.Http Spar.Sem.IdP @@ -57,6 +61,7 @@ library Spar.Sem.Logger Spar.Sem.Logger.TinyLog Spar.Sem.Now + Spar.Sem.Now.Input Spar.Sem.Now.IO Spar.Sem.Random Spar.Sem.Random.IO @@ -68,14 +73,19 @@ library Spar.Sem.SamlProtocolSettings.Servant Spar.Sem.SAMLUserStore Spar.Sem.SAMLUserStore.Cassandra + Spar.Sem.SAMLUserStore.Mem Spar.Sem.ScimExternalIdStore Spar.Sem.ScimExternalIdStore.Cassandra + Spar.Sem.ScimExternalIdStore.Mem Spar.Sem.ScimTokenStore Spar.Sem.ScimTokenStore.Cassandra + Spar.Sem.ScimTokenStore.Mem Spar.Sem.ScimUserTimesStore Spar.Sem.ScimUserTimesStore.Cassandra + Spar.Sem.ScimUserTimesStore.Mem Spar.Sem.VerdictFormatStore Spar.Sem.VerdictFormatStore.Cassandra + Spar.Sem.VerdictFormatStore.Mem other-modules: Paths_spar hs-source-dirs: diff --git a/services/spar/src/Spar/Sem/AReqIDStore/Mem.hs b/services/spar/src/Spar/Sem/AReqIDStore/Mem.hs new file mode 100644 index 00000000000..cd1343838cf --- /dev/null +++ b/services/spar/src/Spar/Sem/AReqIDStore/Mem.hs @@ -0,0 +1,26 @@ +{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} + +module Spar.Sem.AReqIDStore.Mem where + +import qualified Data.Map as M +import Imports +import Polysemy +import Polysemy.State +import qualified SAML2.WebSSO.Types as SAML +import Spar.Sem.AReqIDStore +import Spar.Sem.Now +import Wire.API.User.Saml (AReqId) + +aReqIDStoreToMem :: + Member Now r => + Sem (AReqIDStore ': r) a -> + Sem r (Map AReqId SAML.Time, a) +aReqIDStoreToMem = (runState mempty .) $ + reinterpret $ \case + Store areqid ti -> modify $ M.insert areqid ti + UnStore areqid -> modify $ M.delete areqid + IsAlive areqid -> + gets (M.lookup areqid) >>= \case + Just time -> do + boolTTL False True time + Nothing -> pure False diff --git a/services/spar/src/Spar/Sem/AssIDStore/Mem.hs b/services/spar/src/Spar/Sem/AssIDStore/Mem.hs new file mode 100644 index 00000000000..45ae969f9cd --- /dev/null +++ b/services/spar/src/Spar/Sem/AssIDStore/Mem.hs @@ -0,0 +1,25 @@ +{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} + +module Spar.Sem.AssIDStore.Mem where + +import qualified Data.Map as M +import Imports +import Polysemy +import Polysemy.State +import qualified SAML2.WebSSO.Types as SAML +import Spar.Sem.AssIDStore +import Spar.Sem.Now +import Wire.API.User.Saml (AssId) + +assIdStoreToMem :: + Member Now r => + Sem (AssIDStore ': r) a -> + Sem r (Map AssId SAML.Time, a) +assIdStoreToMem = (runState mempty .) $ + reinterpret $ \case + Store assid ti -> modify $ M.insert assid ti + UnStore assid -> modify $ M.delete assid + IsAlive assid -> + gets (M.lookup assid) >>= \case + Just time -> boolTTL False True time + Nothing -> pure False diff --git a/services/spar/src/Spar/Sem/BindCookieStore/Mem.hs b/services/spar/src/Spar/Sem/BindCookieStore/Mem.hs new file mode 100644 index 00000000000..c25acc73808 --- /dev/null +++ b/services/spar/src/Spar/Sem/BindCookieStore/Mem.hs @@ -0,0 +1,28 @@ +module Spar.Sem.BindCookieStore.Mem where + +import Data.Id (UserId) +import qualified Data.Map as M +import Data.String.Conversions (cs) +import Imports +import Polysemy +import Polysemy.State +import SAML2.WebSSO +import qualified SAML2.WebSSO.Cookie as SAML +import qualified SAML2.WebSSO.Types as SAML +import Spar.Sem.BindCookieStore +import Spar.Sem.Now +import qualified Spar.Sem.Now as Now +import qualified Web.Cookie as Cky +import Wire.API.Cookie + +bindCookieStoreToMem :: Member Now r => Sem (BindCookieStore ': r) a -> Sem r (Map BindCookie (SAML.Time, UserId), a) +bindCookieStoreToMem = (runState mempty .) $ + reinterpret $ \case + Insert sbc uid ndt -> do + let ckyval = BindCookie . cs . Cky.setCookieValue . SAML.fromSimpleSetCookie . getSimpleSetCookie $ sbc + now <- Now.get + modify $ M.insert ckyval (addTime ndt now, uid) + Lookup bc -> do + gets (M.lookup bc) >>= \case + Just (time, uid) -> boolTTL Nothing (Just uid) time + Nothing -> pure Nothing diff --git a/services/spar/src/Spar/Sem/DefaultSsoCode/Mem.hs b/services/spar/src/Spar/Sem/DefaultSsoCode/Mem.hs new file mode 100644 index 00000000000..a6be5be98b0 --- /dev/null +++ b/services/spar/src/Spar/Sem/DefaultSsoCode/Mem.hs @@ -0,0 +1,16 @@ +{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} + +module Spar.Sem.DefaultSsoCode.Mem where + +import Imports +import Polysemy +import Polysemy.State (get, put, runState) +import qualified SAML2.WebSSO as SAML +import Spar.Sem.DefaultSsoCode (DefaultSsoCode (..)) + +defaultSsoCodeToMem :: Sem (DefaultSsoCode ': r) a -> Sem r (Maybe SAML.IdPId, a) +defaultSsoCodeToMem = (runState Nothing .) $ + reinterpret $ \case + Get -> get + Store ipi -> put $ Just ipi + Delete -> put Nothing diff --git a/services/spar/src/Spar/Sem/Now.hs b/services/spar/src/Spar/Sem/Now.hs index 4c43be4a466..63d8e740ad5 100644 --- a/services/spar/src/Spar/Sem/Now.hs +++ b/services/spar/src/Spar/Sem/Now.hs @@ -1,5 +1,6 @@ module Spar.Sem.Now where +import Imports import Polysemy import qualified SAML2.WebSSO as SAML @@ -7,3 +8,16 @@ data Now m a where Get :: Now m SAML.Time makeSem ''Now + +-- | Check a time against 'Now', checking if it's still alive (hasn't occurred yet.) +boolTTL :: + Member Now r => + -- | The value to return if the TTL is expired + a -> + -- | The value to return if the TTL is alive + a -> + SAML.Time -> -- The time to check + Sem r a +boolTTL f t time = do + now <- get + pure $ bool f t $ now <= time diff --git a/services/spar/src/Spar/Sem/Now/Input.hs b/services/spar/src/Spar/Sem/Now/Input.hs new file mode 100644 index 00000000000..738424f9552 --- /dev/null +++ b/services/spar/src/Spar/Sem/Now/Input.hs @@ -0,0 +1,14 @@ +module Spar.Sem.Now.Input where + +import Imports +import Polysemy +import Polysemy.Input +import qualified SAML2.WebSSO as SAML +import Spar.Sem.Now + +nowToInput :: + Member (Input SAML.Time) r => + Sem (Now ': r) a -> + Sem r a +nowToInput = interpret $ \case + Get -> input diff --git a/services/spar/src/Spar/Sem/SAMLUserStore/Mem.hs b/services/spar/src/Spar/Sem/SAMLUserStore/Mem.hs new file mode 100644 index 00000000000..26ae7ab48ae --- /dev/null +++ b/services/spar/src/Spar/Sem/SAMLUserStore/Mem.hs @@ -0,0 +1,34 @@ +{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} + +module Spar.Sem.SAMLUserStore.Mem where + +import Control.Lens (view) +import Data.Coerce (coerce) +import Data.Id +import qualified Data.Map as M +import Imports +import Polysemy +import Polysemy.State (gets, modify, runState) +import SAML2.WebSSO (uidTenant) +import qualified SAML2.WebSSO as SAML +import Spar.Sem.SAMLUserStore + +newtype UserRefOrd = UserRefOrd {unUserRefOrd :: SAML.UserRef} + deriving (Eq) + +instance Ord UserRefOrd where + compare (UserRefOrd (SAML.UserRef is ni)) (UserRefOrd (SAML.UserRef is' ni')) = + compare is is' <> compare ni ni' + +samlUserStoreToMem :: Sem (SAMLUserStore ': r) a -> Sem r (Map UserRefOrd UserId, a) +samlUserStoreToMem = (runState @(Map UserRefOrd UserId) mempty .) $ + reinterpret $ \case + Insert ur uid -> modify $ M.insert (UserRefOrd ur) uid + Get ur -> gets $ M.lookup $ UserRefOrd ur + GetAnyByIssuer is -> gets $ fmap snd . find (eqIssuer is . fst) . M.toList + GetSomeByIssuer is -> gets $ coerce . filter (eqIssuer is . fst) . M.toList + DeleteByIssuer is -> modify $ M.filterWithKey (\ref _ -> not $ eqIssuer is ref) + Delete _uid ur -> modify $ M.delete $ UserRefOrd ur + where + eqIssuer :: SAML.Issuer -> UserRefOrd -> Bool + eqIssuer is = (== is) . view uidTenant . unUserRefOrd diff --git a/services/spar/src/Spar/Sem/ScimExternalIdStore/Mem.hs b/services/spar/src/Spar/Sem/ScimExternalIdStore/Mem.hs new file mode 100644 index 00000000000..efbbbcdba09 --- /dev/null +++ b/services/spar/src/Spar/Sem/ScimExternalIdStore/Mem.hs @@ -0,0 +1,20 @@ +{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} + +module Spar.Sem.ScimExternalIdStore.Mem where + +import Data.Id (TeamId, UserId) +import qualified Data.Map as M +import Imports +import Polysemy +import Polysemy.State +import Spar.Sem.ScimExternalIdStore +import Wire.API.User.Identity (Email) + +scimExternalIdStoreToMem :: + Sem (ScimExternalIdStore ': r) a -> + Sem r (Map (TeamId, Email) UserId, a) +scimExternalIdStoreToMem = (runState mempty .) $ + reinterpret $ \case + Insert tid em uid -> modify $ M.insert (tid, em) uid + Lookup tid em -> gets $ M.lookup (tid, em) + Delete tid em -> modify $ M.delete (tid, em) diff --git a/services/spar/src/Spar/Sem/ScimTokenStore/Mem.hs b/services/spar/src/Spar/Sem/ScimTokenStore/Mem.hs new file mode 100644 index 00000000000..b983208bef9 --- /dev/null +++ b/services/spar/src/Spar/Sem/ScimTokenStore/Mem.hs @@ -0,0 +1,21 @@ +{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} + +module Spar.Sem.ScimTokenStore.Mem where + +import qualified Data.Map as M +import Imports +import Polysemy +import Polysemy.State +import Spar.Scim +import Spar.Sem.ScimTokenStore + +scimTokenStoreToMem :: + Sem (ScimTokenStore ': r) a -> + Sem r (Map ScimToken ScimTokenInfo, a) +scimTokenStoreToMem = (runState mempty .) $ + reinterpret $ \case + Insert st sti -> modify $ M.insert st sti + Lookup st -> gets $ M.lookup st + GetByTeam tid -> gets $ filter ((== tid) . stiTeam) . M.elems + Delete tid stid -> modify $ M.filter $ \sti -> not $ stiTeam sti == tid && stiId sti == stid + DeleteByTeam tid -> modify $ M.filter (not . (== tid) . stiTeam) diff --git a/services/spar/src/Spar/Sem/ScimUserTimesStore.hs b/services/spar/src/Spar/Sem/ScimUserTimesStore.hs index 63065c7ad68..47554a8d001 100644 --- a/services/spar/src/Spar/Sem/ScimUserTimesStore.hs +++ b/services/spar/src/Spar/Sem/ScimUserTimesStore.hs @@ -8,7 +8,7 @@ import Web.Scim.Schema.Common (WithId) import Web.Scim.Schema.Meta (WithMeta) data ScimUserTimesStore m a where - Write :: WithMeta (WithId UserId a) -> ScimUserTimesStore m () + Write :: WithMeta (WithId UserId t) -> ScimUserTimesStore m () Read :: UserId -> ScimUserTimesStore m (Maybe (UTCTimeMillis, UTCTimeMillis)) Delete :: UserId -> ScimUserTimesStore m () diff --git a/services/spar/src/Spar/Sem/ScimUserTimesStore/Mem.hs b/services/spar/src/Spar/Sem/ScimUserTimesStore/Mem.hs new file mode 100644 index 00000000000..b9ed6216b42 --- /dev/null +++ b/services/spar/src/Spar/Sem/ScimUserTimesStore/Mem.hs @@ -0,0 +1,22 @@ +{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} + +module Spar.Sem.ScimUserTimesStore.Mem where + +import Data.Id (UserId) +import Data.Json.Util (UTCTimeMillis, toUTCTimeMillis) +import qualified Data.Map as M +import Imports +import Polysemy +import Polysemy.State +import Spar.Sem.ScimUserTimesStore +import Web.Scim.Schema.Common (WithId (WithId)) +import Web.Scim.Schema.Meta (WithMeta (WithMeta), created, lastModified) + +scimUserTimesStoreToMem :: + Sem (ScimUserTimesStore ': r) a -> + Sem r (Map UserId (UTCTimeMillis, UTCTimeMillis), a) +scimUserTimesStoreToMem = (runState mempty .) $ + reinterpret $ \case + Write (WithMeta meta (WithId uid _)) -> modify $ M.insert uid (toUTCTimeMillis $ created meta, toUTCTimeMillis $ lastModified meta) + Read uid -> gets $ M.lookup uid + Delete uid -> modify $ M.delete uid diff --git a/services/spar/src/Spar/Sem/VerdictFormatStore/Mem.hs b/services/spar/src/Spar/Sem/VerdictFormatStore/Mem.hs new file mode 100644 index 00000000000..73ce9311232 --- /dev/null +++ b/services/spar/src/Spar/Sem/VerdictFormatStore/Mem.hs @@ -0,0 +1,30 @@ +{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} + +module Spar.Sem.VerdictFormatStore.Mem where + +import qualified Data.Map as M +import Imports +import Polysemy +import Polysemy.State hiding (Get) +import SAML2.WebSSO (addTime) +import qualified SAML2.WebSSO.Types as SAML +import Spar.Sem.Now (Now, boolTTL) +import qualified Spar.Sem.Now as Now +import Spar.Sem.VerdictFormatStore +import Wire.API.User.Saml (AReqId, VerdictFormat) + +verdictFormatStoreToMem :: + Member Now r => + Sem (VerdictFormatStore ': r) a -> + Sem r (Map AReqId (SAML.Time, VerdictFormat), a) +verdictFormatStoreToMem = + (runState mempty .) $ + reinterpret $ \case + Store ndt areqid vf -> do + now <- Now.get + modify $ M.insert areqid (addTime ndt now, vf) + Get areqid -> do + gets (M.lookup areqid) >>= \case + Just (time, vf) -> do + boolTTL Nothing (Just vf) time + Nothing -> pure Nothing From 39f45ffe1906dd8de35d9a1e3e34db394fd294cb Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Thu, 25 Nov 2021 20:22:41 +0100 Subject: [PATCH 11/28] (Un-)lock Status for Self-Deleting Messages (#1937) --- changelog.d/0-release-notes/pr-1937 | 1 + ...e-config-seld-del-msgs-with-payment-status | 1 + .../set-payment-status-self-del-msgs | 1 + .../set-payment-status-for-self-del-msgs | 1 + docs/reference/cassandra-schema.cql | 1 + libs/galley-types/src/Galley/Types/Teams.hs | 10 +- .../src/Wire/API/Routes/Internal/Brig.hs | 4 +- .../src/Wire/API/Routes/Public/Galley.hs | 44 +-- .../src/Wire/API/Routes/Public/LegalHold.hs | 4 +- libs/wire-api/src/Wire/API/Swagger.hs | 1 + libs/wire-api/src/Wire/API/Team/Feature.hs | 147 ++++++++-- .../golden/Test/Wire/API/Golden/Generator.hs | 4 +- .../unit/Test/Wire/API/Roundtrip/Aeson.hs | 24 +- services/brig/src/Brig/IO/Intra.hs | 4 +- services/brig/src/Brig/Options.hs | 4 +- services/galley/galley.cabal | 1 + services/galley/schema/src/Main.hs | 6 +- .../src/V55_SelfDeletingMessagesLockStatus.hs | 33 +++ services/galley/src/Galley/API/Error.hs | 5 + services/galley/src/Galley/API/Internal.hs | 104 ++++--- services/galley/src/Galley/API/LegalHold.hs | 2 +- services/galley/src/Galley/API/Public.hs | 46 +-- services/galley/src/Galley/API/Teams.hs | 4 +- .../galley/src/Galley/API/Teams/Features.hs | 277 +++++++++++------- services/galley/src/Galley/Cassandra.hs | 2 +- .../src/Galley/Cassandra/TeamFeatures.hs | 93 ++++-- .../galley/src/Galley/Data/TeamFeatures.hs | 32 +- .../src/Galley/Effects/TeamFeatureStore.hs | 76 +++-- services/galley/test/integration/API/Teams.hs | 10 +- .../test/integration/API/Teams/Feature.hs | 166 +++++++---- .../test/integration/API/Teams/LegalHold.hs | 6 +- .../API/Teams/LegalHold/DisabledByDefault.hs | 10 +- .../test/integration/API/Util/TeamFeature.hs | 53 ++-- services/spar/src/Spar/Intra/Galley.hs | 10 +- tools/stern/src/Stern/API.hs | 24 +- tools/stern/src/Stern/Intra.hs | 14 +- 36 files changed, 827 insertions(+), 398 deletions(-) create mode 100644 changelog.d/0-release-notes/pr-1937 create mode 100644 changelog.d/1-api-changes/get-feature-config-seld-del-msgs-with-payment-status create mode 100644 changelog.d/1-api-changes/set-payment-status-self-del-msgs create mode 100644 changelog.d/2-features/set-payment-status-for-self-del-msgs create mode 100644 services/galley/schema/src/V55_SelfDeletingMessagesLockStatus.hs diff --git a/changelog.d/0-release-notes/pr-1937 b/changelog.d/0-release-notes/pr-1937 new file mode 100644 index 00000000000..85e7a39820c --- /dev/null +++ b/changelog.d/0-release-notes/pr-1937 @@ -0,0 +1 @@ +If you have `selfDeletingMessages` configured in `galley.yaml`, add `lockStatus: unlocked`. diff --git a/changelog.d/1-api-changes/get-feature-config-seld-del-msgs-with-payment-status b/changelog.d/1-api-changes/get-feature-config-seld-del-msgs-with-payment-status new file mode 100644 index 00000000000..d1855d92dde --- /dev/null +++ b/changelog.d/1-api-changes/get-feature-config-seld-del-msgs-with-payment-status @@ -0,0 +1 @@ +get team feature config for self deleting messages response includes lock status diff --git a/changelog.d/1-api-changes/set-payment-status-self-del-msgs b/changelog.d/1-api-changes/set-payment-status-self-del-msgs new file mode 100644 index 00000000000..3cca58aab4f --- /dev/null +++ b/changelog.d/1-api-changes/set-payment-status-self-del-msgs @@ -0,0 +1 @@ +new internal endpoints for setting the lock status of self deleting messages diff --git a/changelog.d/2-features/set-payment-status-for-self-del-msgs b/changelog.d/2-features/set-payment-status-for-self-del-msgs new file mode 100644 index 00000000000..1b0c9e647be --- /dev/null +++ b/changelog.d/2-features/set-payment-status-for-self-del-msgs @@ -0,0 +1 @@ +Lock status for the self deleting messages feature can be set internally by ibis and customer support diff --git a/docs/reference/cassandra-schema.cql b/docs/reference/cassandra-schema.cql index 7b70e2f4642..43505d0d58f 100644 --- a/docs/reference/cassandra-schema.cql +++ b/docs/reference/cassandra-schema.cql @@ -422,6 +422,7 @@ CREATE TABLE galley_test.team_features ( file_sharing int, legalhold_status int, search_visibility_status int, + self_deleting_messages_lock_status int, self_deleting_messages_status int, self_deleting_messages_ttl int, sso_status int, diff --git a/libs/galley-types/src/Galley/Types/Teams.hs b/libs/galley-types/src/Galley/Types/Teams.hs index 8e727e90a1d..d1b0d1851ab 100644 --- a/libs/galley-types/src/Galley/Types/Teams.hs +++ b/libs/galley-types/src/Galley/Types/Teams.hs @@ -212,11 +212,11 @@ data FeatureFlags = FeatureFlags { _flagSSO :: !FeatureSSO, _flagLegalHold :: !FeatureLegalHold, _flagTeamSearchVisibility :: !FeatureTeamSearchVisibility, - _flagAppLockDefaults :: !(Defaults (TeamFeatureStatus 'TeamFeatureAppLock)), - _flagClassifiedDomains :: !(TeamFeatureStatus 'TeamFeatureClassifiedDomains), - _flagFileSharing :: !(Defaults (TeamFeatureStatus 'TeamFeatureFileSharing)), - _flagConferenceCalling :: !(Defaults (TeamFeatureStatus 'TeamFeatureConferenceCalling)), - _flagSelfDeletingMessages :: !(Defaults (TeamFeatureStatus 'TeamFeatureSelfDeletingMessages)) + _flagAppLockDefaults :: !(Defaults (TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureAppLock)), + _flagClassifiedDomains :: !(TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureClassifiedDomains), + _flagFileSharing :: !(Defaults (TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureFileSharing)), + _flagConferenceCalling :: !(Defaults (TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureConferenceCalling)), + _flagSelfDeletingMessages :: !(Defaults (TeamFeatureStatus 'WithLockStatus 'TeamFeatureSelfDeletingMessages)) } deriving (Eq, Show, Generic) diff --git a/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs b/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs index 51e34b18d40..5027a554056 100644 --- a/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs +++ b/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs @@ -66,7 +66,7 @@ type GetAccountFeatureConfig = :> Capture "uid" UserId :> "features" :> "conferenceCalling" - :> Get '[Servant.JSON] (ApiFt.TeamFeatureStatus 'ApiFt.TeamFeatureConferenceCalling) + :> Get '[Servant.JSON] (ApiFt.TeamFeatureStatus 'ApiFt.WithLockStatus 'ApiFt.TeamFeatureConferenceCalling) type PutAccountFeatureConfig = Summary @@ -75,7 +75,7 @@ type PutAccountFeatureConfig = :> Capture "uid" UserId :> "features" :> "conferenceCalling" - :> Servant.ReqBody '[Servant.JSON] (ApiFt.TeamFeatureStatus 'ApiFt.TeamFeatureConferenceCalling) + :> Servant.ReqBody '[Servant.JSON] (ApiFt.TeamFeatureStatus 'ApiFt.WithoutLockStatus 'ApiFt.TeamFeatureConferenceCalling) :> Put '[Servant.JSON] NoContent type DeleteAccountFeatureConfig = diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs b/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs index 7aafbfa7bf7..ff1dc2ed877 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs @@ -623,7 +623,7 @@ data Api routes = Api :- FeatureStatusPut 'TeamFeatureSearchVisibility, teamFeatureStatusSearchVisibilityDeprecatedGet :: routes - :- FeatureStatusDeprecatedGet 'TeamFeatureSearchVisibility, + :- FeatureStatusDeprecatedGet 'WithoutLockStatus 'TeamFeatureSearchVisibility, teamFeatureStatusSearchVisibilityDeprecatedPut :: routes :- FeatureStatusDeprecatedPut 'TeamFeatureSearchVisibility, @@ -632,13 +632,13 @@ data Api routes = Api :- FeatureStatusGet 'TeamFeatureValidateSAMLEmails, teamFeatureStatusValidateSAMLEmailsDeprecatedGet :: routes - :- FeatureStatusDeprecatedGet 'TeamFeatureValidateSAMLEmails, + :- FeatureStatusDeprecatedGet 'WithoutLockStatus 'TeamFeatureValidateSAMLEmails, teamFeatureStatusDigitalSignaturesGet :: routes :- FeatureStatusGet 'TeamFeatureDigitalSignatures, teamFeatureStatusDigitalSignaturesDeprecatedGet :: routes - :- FeatureStatusDeprecatedGet 'TeamFeatureDigitalSignatures, + :- FeatureStatusDeprecatedGet 'WithoutLockStatus 'TeamFeatureDigitalSignatures, teamFeatureStatusAppLockGet :: routes :- FeatureStatusGet 'TeamFeatureAppLock, @@ -668,34 +668,34 @@ data Api routes = Api :- AllFeatureConfigsGet, featureConfigLegalHoldGet :: routes - :- FeatureConfigGet 'TeamFeatureLegalHold, + :- FeatureConfigGet 'WithoutLockStatus 'TeamFeatureLegalHold, featureConfigSSOGet :: routes - :- FeatureConfigGet 'TeamFeatureSSO, + :- FeatureConfigGet 'WithoutLockStatus 'TeamFeatureSSO, featureConfigSearchVisibilityGet :: routes - :- FeatureConfigGet 'TeamFeatureSearchVisibility, + :- FeatureConfigGet 'WithoutLockStatus 'TeamFeatureSearchVisibility, featureConfigValidateSAMLEmailsGet :: routes - :- FeatureConfigGet 'TeamFeatureValidateSAMLEmails, + :- FeatureConfigGet 'WithoutLockStatus 'TeamFeatureValidateSAMLEmails, featureConfigDigitalSignaturesGet :: routes - :- FeatureConfigGet 'TeamFeatureDigitalSignatures, + :- FeatureConfigGet 'WithoutLockStatus 'TeamFeatureDigitalSignatures, featureConfigAppLockGet :: routes - :- FeatureConfigGet 'TeamFeatureAppLock, + :- FeatureConfigGet 'WithoutLockStatus 'TeamFeatureAppLock, featureConfigFileSharingGet :: routes - :- FeatureConfigGet 'TeamFeatureFileSharing, + :- FeatureConfigGet 'WithoutLockStatus 'TeamFeatureFileSharing, featureConfigClassifiedDomainsGet :: routes - :- FeatureConfigGet 'TeamFeatureClassifiedDomains, + :- FeatureConfigGet 'WithoutLockStatus 'TeamFeatureClassifiedDomains, featureConfigConferenceCallingGet :: routes - :- FeatureConfigGet 'TeamFeatureConferenceCalling, + :- FeatureConfigGet 'WithoutLockStatus 'TeamFeatureConferenceCalling, featureConfigSelfDeletingMessagesGet :: routes - :- FeatureConfigGet 'TeamFeatureSelfDeletingMessages + :- FeatureConfigGet 'WithLockStatus 'TeamFeatureSelfDeletingMessages } deriving (Generic) @@ -708,7 +708,7 @@ type FeatureStatusGet featureName = :> Capture "tid" TeamId :> "features" :> KnownTeamFeatureNameSymbol featureName - :> Get '[Servant.JSON] (TeamFeatureStatus featureName) + :> Get '[Servant.JSON] (TeamFeatureStatus 'WithLockStatus featureName) type FeatureStatusPut featureName = Summary (AppendSymbol "Put config for " (KnownTeamFeatureNameSymbol featureName)) @@ -717,18 +717,18 @@ type FeatureStatusPut featureName = :> Capture "tid" TeamId :> "features" :> KnownTeamFeatureNameSymbol featureName - :> ReqBody '[Servant.JSON] (TeamFeatureStatus featureName) - :> Put '[Servant.JSON] (TeamFeatureStatus featureName) + :> ReqBody '[Servant.JSON] (TeamFeatureStatus 'WithoutLockStatus featureName) + :> Put '[Servant.JSON] (TeamFeatureStatus 'WithoutLockStatus featureName) -- | A type for a GET endpoint for a feature with a deprecated path -type FeatureStatusDeprecatedGet featureName = +type FeatureStatusDeprecatedGet ps featureName = Summary (AppendSymbol "[deprecated] Get config for " (KnownTeamFeatureNameSymbol featureName)) :> ZUser :> "teams" :> Capture "tid" TeamId :> "features" :> DeprecatedFeatureName featureName - :> Get '[Servant.JSON] (TeamFeatureStatus featureName) + :> Get '[Servant.JSON] (TeamFeatureStatus ps featureName) -- | A type for a PUT endpoint for a feature with a deprecated path type FeatureStatusDeprecatedPut featureName = @@ -738,15 +738,15 @@ type FeatureStatusDeprecatedPut featureName = :> Capture "tid" TeamId :> "features" :> DeprecatedFeatureName featureName - :> ReqBody '[Servant.JSON] (TeamFeatureStatus featureName) - :> Put '[Servant.JSON] (TeamFeatureStatus featureName) + :> ReqBody '[Servant.JSON] (TeamFeatureStatus 'WithoutLockStatus featureName) + :> Put '[Servant.JSON] (TeamFeatureStatus 'WithoutLockStatus featureName) -type FeatureConfigGet featureName = +type FeatureConfigGet ps featureName = Summary (AppendSymbol "Get feature config for feature " (KnownTeamFeatureNameSymbol featureName)) :> ZUser :> "feature-configs" :> KnownTeamFeatureNameSymbol featureName - :> Get '[Servant.JSON] (TeamFeatureStatus featureName) + :> Get '[Servant.JSON] (TeamFeatureStatus ps featureName) type AllFeatureConfigsGet = Summary "Get configurations of all features" diff --git a/libs/wire-api/src/Wire/API/Routes/Public/LegalHold.hs b/libs/wire-api/src/Wire/API/Routes/Public/LegalHold.hs index 6bb24b75430..6c3db162ae9 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/LegalHold.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/LegalHold.hs @@ -52,9 +52,9 @@ type PublicAPI = type InternalAPI = "i" :> "teams" :> Capture "tid" TeamId :> "legalhold" - :> Get '[JSON] (TeamFeatureStatus 'TeamFeatureLegalHold) + :> Get '[JSON] (TeamFeatureStatus 'WithLockStatus 'TeamFeatureLegalHold) :<|> "i" :> "teams" :> Capture "tid" TeamId :> "legalhold" - :> ReqBody '[JSON] (TeamFeatureStatus 'TeamFeatureLegalHold) + :> ReqBody '[JSON] (TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureLegalHold) :> Put '[] NoContent swaggerDoc :: Swagger diff --git a/libs/wire-api/src/Wire/API/Swagger.hs b/libs/wire-api/src/Wire/API/Swagger.hs index f746c3465c3..68160851619 100644 --- a/libs/wire-api/src/Wire/API/Swagger.hs +++ b/libs/wire-api/src/Wire/API/Swagger.hs @@ -129,6 +129,7 @@ models = Team.Feature.modelTeamFeatureAppLockConfig, Team.Feature.modelTeamFeatureClassifiedDomainsConfig, Team.Feature.modelTeamFeatureSelfDeletingMessagesConfig, + Team.Feature.modelLockStatus, Team.Invitation.modelTeamInvitation, Team.Invitation.modelTeamInvitationList, Team.Invitation.modelTeamInvitationRequest, diff --git a/libs/wire-api/src/Wire/API/Team/Feature.hs b/libs/wire-api/src/Wire/API/Team/Feature.hs index f466fe3102c..aa1bdc89726 100644 --- a/libs/wire-api/src/Wire/API/Team/Feature.hs +++ b/libs/wire-api/src/Wire/API/Team/Feature.hs @@ -30,8 +30,12 @@ module Wire.API.Team.Feature KnownTeamFeatureName (..), TeamFeatureStatusNoConfig (..), TeamFeatureStatusWithConfig (..), + TeamFeatureStatusWithConfigAndLockStatus (..), HasDeprecatedFeatureName (..), AllFeatureConfigs (..), + LockStatus (..), + LockStatusValue (..), + IncludeLockStatus (..), defaultAppLockStatus, defaultClassifiedDomains, defaultSelfDeletingMessagesStatus, @@ -44,7 +48,9 @@ module Wire.API.Team.Feature modelTeamFeatureAppLockConfig, modelTeamFeatureClassifiedDomainsConfig, modelTeamFeatureSelfDeletingMessagesConfig, + modelTeamFeatureStatusWithConfigAndLockStatus, modelForTeamFeature, + modelLockStatus, ) where @@ -52,8 +58,9 @@ import qualified Cassandra.CQL as Cass import Control.Lens.Combinators (dimap) import qualified Data.Aeson as Aeson import qualified Data.Attoparsec.ByteString as Parser -import Data.ByteString.Conversion (FromByteString (..), ToByteString (..), toByteString') +import Data.ByteString.Conversion (FromByteString (..), ToByteString (..), fromByteString, toByteString') import Data.Domain (Domain) +import Data.Either.Extra (maybeToEither) import Data.Kind (Constraint) import Data.Schema import Data.String.Conversions (cs) @@ -64,6 +71,7 @@ import qualified Data.Text.Encoding as T import Deriving.Aeson import GHC.TypeLits (Symbol) import Imports +import Servant (FromHttpApiData (..)) import Test.QuickCheck.Arbitrary (arbitrary) import Wire.API.Arbitrary (Arbitrary, GenericUniform (..)) @@ -272,8 +280,8 @@ instance Cass.Cql TeamFeatureStatusValue where ctype = Cass.Tagged Cass.IntColumn fromCql (Cass.CqlInt n) = case n of - 0 -> pure $ TeamFeatureDisabled - 1 -> pure $ TeamFeatureEnabled + 0 -> pure TeamFeatureDisabled + 1 -> pure TeamFeatureEnabled _ -> Left "fromCql: Invalid TeamFeatureStatusValue" fromCql _ = Left "fromCql: TeamFeatureStatusValue: CqlInt expected" @@ -283,19 +291,22 @@ instance Cass.Cql TeamFeatureStatusValue where ---------------------------------------------------------------------- -- TeamFeatureStatus -type family TeamFeatureStatus (a :: TeamFeatureName) :: * where - TeamFeatureStatus 'TeamFeatureLegalHold = TeamFeatureStatusNoConfig - TeamFeatureStatus 'TeamFeatureSSO = TeamFeatureStatusNoConfig - TeamFeatureStatus 'TeamFeatureSearchVisibility = TeamFeatureStatusNoConfig - TeamFeatureStatus 'TeamFeatureValidateSAMLEmails = TeamFeatureStatusNoConfig - TeamFeatureStatus 'TeamFeatureDigitalSignatures = TeamFeatureStatusNoConfig - TeamFeatureStatus 'TeamFeatureAppLock = TeamFeatureStatusWithConfig TeamFeatureAppLockConfig - TeamFeatureStatus 'TeamFeatureFileSharing = TeamFeatureStatusNoConfig - TeamFeatureStatus 'TeamFeatureClassifiedDomains = TeamFeatureStatusWithConfig TeamFeatureClassifiedDomainsConfig - TeamFeatureStatus 'TeamFeatureConferenceCalling = TeamFeatureStatusNoConfig - TeamFeatureStatus 'TeamFeatureSelfDeletingMessages = TeamFeatureStatusWithConfig TeamFeatureSelfDeletingMessagesConfig +data IncludeLockStatus = WithLockStatus | WithoutLockStatus -type FeatureHasNoConfig (a :: TeamFeatureName) = (TeamFeatureStatus a ~ TeamFeatureStatusNoConfig) :: Constraint +type family TeamFeatureStatus (ps :: IncludeLockStatus) (a :: TeamFeatureName) :: * where + TeamFeatureStatus _ 'TeamFeatureLegalHold = TeamFeatureStatusNoConfig + TeamFeatureStatus _ 'TeamFeatureSSO = TeamFeatureStatusNoConfig + TeamFeatureStatus _ 'TeamFeatureSearchVisibility = TeamFeatureStatusNoConfig + TeamFeatureStatus _ 'TeamFeatureValidateSAMLEmails = TeamFeatureStatusNoConfig + TeamFeatureStatus _ 'TeamFeatureDigitalSignatures = TeamFeatureStatusNoConfig + TeamFeatureStatus _ 'TeamFeatureAppLock = TeamFeatureStatusWithConfig TeamFeatureAppLockConfig + TeamFeatureStatus _ 'TeamFeatureFileSharing = TeamFeatureStatusNoConfig + TeamFeatureStatus _ 'TeamFeatureClassifiedDomains = TeamFeatureStatusWithConfig TeamFeatureClassifiedDomainsConfig + TeamFeatureStatus _ 'TeamFeatureConferenceCalling = TeamFeatureStatusNoConfig + TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureSelfDeletingMessages = TeamFeatureStatusWithConfig TeamFeatureSelfDeletingMessagesConfig + TeamFeatureStatus 'WithLockStatus 'TeamFeatureSelfDeletingMessages = TeamFeatureStatusWithConfigAndLockStatus TeamFeatureSelfDeletingMessagesConfig + +type FeatureHasNoConfig (ps :: IncludeLockStatus) (a :: TeamFeatureName) = (TeamFeatureStatus ps a ~ TeamFeatureStatusNoConfig) :: Constraint -- if you add a new constructor here, don't forget to add it to the swagger (1.2) docs in "Wire.API.Swagger"! modelForTeamFeature :: TeamFeatureName -> Doc.Model @@ -360,6 +371,32 @@ instance ToSchema cfg => ToSchema (TeamFeatureStatusWithConfig cfg) where <$> tfwcStatus .= field "status" schema <*> tfwcConfig .= field "config" schema +data TeamFeatureStatusWithConfigAndLockStatus (cfg :: *) = TeamFeatureStatusWithConfigAndLockStatus + { tfwcapsStatus :: TeamFeatureStatusValue, + tfwcapsConfig :: cfg, + tfwcapsLockStatus :: LockStatusValue + } + deriving stock (Eq, Show, Generic, Typeable) + deriving (ToJSON, FromJSON, S.ToSchema) via (Schema (TeamFeatureStatusWithConfigAndLockStatus cfg)) + +instance Arbitrary cfg => Arbitrary (TeamFeatureStatusWithConfigAndLockStatus cfg) where + arbitrary = TeamFeatureStatusWithConfigAndLockStatus <$> arbitrary <*> arbitrary <*> arbitrary + +modelTeamFeatureStatusWithConfigAndLockStatus :: TeamFeatureName -> Doc.Model -> Doc.Model +modelTeamFeatureStatusWithConfigAndLockStatus name cfgModel = Doc.defineModel (cs $ show name) $ do + Doc.description $ "Status and config of " <> cs (show name) + Doc.property "status" typeTeamFeatureStatusValue $ Doc.description "status" + Doc.property "config" (Doc.ref cfgModel) $ Doc.description "config" + Doc.property "lockStatus" typeLockStatusValue $ Doc.description "config" + +instance ToSchema cfg => ToSchema (TeamFeatureStatusWithConfigAndLockStatus cfg) where + schema = + object "TeamFeatureStatusWithConfigAndLockStatus" $ + TeamFeatureStatusWithConfigAndLockStatus + <$> tfwcapsStatus .= field "status" schema + <*> tfwcapsConfig .= field "config" schema + <*> tfwcapsLockStatus .= field "lockStatus" schema + ---------------------------------------------------------------------- -- TeamFeatureClassifiedDomainsConfig @@ -383,7 +420,10 @@ modelTeamFeatureClassifiedDomainsConfig = Doc.property "domains" (Doc.array Doc.string') $ Doc.description "domains" defaultClassifiedDomains :: TeamFeatureStatusWithConfig TeamFeatureClassifiedDomainsConfig -defaultClassifiedDomains = TeamFeatureStatusWithConfig TeamFeatureDisabled (TeamFeatureClassifiedDomainsConfig []) +defaultClassifiedDomains = + TeamFeatureStatusWithConfig + TeamFeatureDisabled + (TeamFeatureClassifiedDomainsConfig []) ---------------------------------------------------------------------- -- TeamFeatureAppLockConfig @@ -445,11 +485,82 @@ modelTeamFeatureSelfDeletingMessagesConfig = Doc.defineModel "TeamFeatureSelfDeletingMessagesConfig" $ do Doc.property "enforcedTimeoutSeconds" Doc.int32' $ Doc.description "optional; default: `0` (no enforcement)" -defaultSelfDeletingMessagesStatus :: TeamFeatureStatusWithConfig TeamFeatureSelfDeletingMessagesConfig +defaultSelfDeletingMessagesStatus :: TeamFeatureStatusWithConfigAndLockStatus TeamFeatureSelfDeletingMessagesConfig defaultSelfDeletingMessagesStatus = - TeamFeatureStatusWithConfig + TeamFeatureStatusWithConfigAndLockStatus TeamFeatureEnabled (TeamFeatureSelfDeletingMessagesConfig 0) + Unlocked + +---------------------------------------------------------------------- +-- LockStatus + +instance FromHttpApiData LockStatusValue where + parseUrlPiece = maybeToEither "Invalid lock status" . fromByteString . cs + +data LockStatusValue = Locked | Unlocked + deriving stock (Eq, Show, Generic) + deriving (Arbitrary) via (GenericUniform LockStatusValue) + deriving (ToJSON, FromJSON, S.ToSchema) via (Schema LockStatusValue) + +newtype LockStatus = LockStatus + { lockStatus :: LockStatusValue + } + deriving stock (Eq, Show, Generic) + deriving (FromJSON, ToJSON, S.ToSchema) via (Schema LockStatus) + deriving (Arbitrary) via (GenericUniform LockStatus) + +instance ToSchema LockStatus where + schema = + object "LockStatus" $ + LockStatus + <$> lockStatus .= field "lockStatus" schema + +modelLockStatus :: Doc.Model +modelLockStatus = + Doc.defineModel "LockStatus" $ do + Doc.property "lockStatus" typeLockStatusValue $ Doc.description "" + +typeLockStatusValue :: Doc.DataType +typeLockStatusValue = + Doc.string $ + Doc.enum + [ "locked", + "unlocked" + ] + +instance ToSchema LockStatusValue where + schema = + enum @Text "LockStatusValue" $ + mconcat + [ element "locked" Locked, + element "unlocked" Unlocked + ] + +instance ToByteString LockStatusValue where + builder Locked = "locked" + builder Unlocked = "unlocked" + +instance FromByteString LockStatusValue where + parser = + Parser.takeByteString >>= \b -> + case T.decodeUtf8' b of + Right "locked" -> pure Locked + Right "unlocked" -> pure Unlocked + Right t -> fail $ "Invalid LockStatusValue: " <> T.unpack t + Left e -> fail $ "Invalid LockStatusValue: " <> show e + +instance Cass.Cql LockStatusValue where + ctype = Cass.Tagged Cass.IntColumn + + fromCql (Cass.CqlInt n) = case n of + 0 -> pure Locked + 1 -> pure Unlocked + _ -> Left "fromCql: Invalid LockStatusValue" + fromCql _ = Left "fromCql: LockStatusValue: CqlInt expected" + + toCql Locked = Cass.CqlInt 0 + toCql Unlocked = Cass.CqlInt 1 ---------------------------------------------------------------------- -- internal diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generator.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generator.hs index 4d022f0eac0..e4daf3da24b 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generator.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generator.hs @@ -328,8 +328,8 @@ generateTestModule = do generateBindingModule @Team.TeamDeleteData "team" ref generateBindingModule @Team.Conversation.TeamConversation "team" ref generateBindingModule @Team.Conversation.TeamConversationList "team" ref - generateBindingModule @(Team.Feature.TeamFeatureStatus 'Team.Feature.TeamFeatureLegalHold) "team" ref - generateBindingModule @(Team.Feature.TeamFeatureStatus 'Team.Feature.TeamFeatureAppLock) "team" ref + generateBindingModule @(Team.Feature.TeamFeatureStatus 'Team.Feature.WithoutLockStatus 'Team.Feature.TeamFeatureLegalHold) "team" ref + generateBindingModule @(Team.Feature.TeamFeatureStatus 'Team.Feature.WithoutLockStatus 'Team.Feature.TeamFeatureAppLock) "team" ref generateBindingModule @Team.Feature.TeamFeatureStatusValue "team" ref generateBindingModule @Team.Invitation.InvitationRequest "team" ref generateBindingModule @Team.Invitation.Invitation "team" ref diff --git a/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/Aeson.hs b/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/Aeson.hs index 6e09181e543..05501016904 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/Aeson.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/Aeson.hs @@ -195,17 +195,21 @@ tests = testRoundTrip @Team.TeamDeleteData, testRoundTrip @Team.Conversation.TeamConversation, testRoundTrip @Team.Conversation.TeamConversationList, - testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.TeamFeatureLegalHold), - testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.TeamFeatureSSO), - testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.TeamFeatureSearchVisibility), - testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.TeamFeatureValidateSAMLEmails), - testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.TeamFeatureDigitalSignatures), - testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.TeamFeatureAppLock), - testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.TeamFeatureFileSharing), - testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.TeamFeatureClassifiedDomains), - testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.TeamFeatureConferenceCalling), - testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.TeamFeatureSelfDeletingMessages), + testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.WithoutLockStatus 'Team.Feature.TeamFeatureLegalHold), + testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.WithoutLockStatus 'Team.Feature.TeamFeatureSSO), + testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.WithoutLockStatus 'Team.Feature.TeamFeatureSearchVisibility), + testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.WithoutLockStatus 'Team.Feature.TeamFeatureValidateSAMLEmails), + testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.WithoutLockStatus 'Team.Feature.TeamFeatureDigitalSignatures), + testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.WithoutLockStatus 'Team.Feature.TeamFeatureAppLock), + testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.WithoutLockStatus 'Team.Feature.TeamFeatureFileSharing), + testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.WithoutLockStatus 'Team.Feature.TeamFeatureClassifiedDomains), + testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.WithoutLockStatus 'Team.Feature.TeamFeatureConferenceCalling), + testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.WithoutLockStatus 'Team.Feature.TeamFeatureSelfDeletingMessages), + testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.WithLockStatus 'Team.Feature.TeamFeatureSelfDeletingMessages), + testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.WithoutLockStatus 'Team.Feature.TeamFeatureSelfDeletingMessages), testRoundTrip @Team.Feature.TeamFeatureStatusValue, + testRoundTrip @Team.Feature.LockStatusValue, + testRoundTrip @Team.Feature.LockStatus, testRoundTrip @Team.Invitation.InvitationRequest, testRoundTrip @Team.Invitation.Invitation, testRoundTrip @Team.Invitation.InvitationList, diff --git a/services/brig/src/Brig/IO/Intra.hs b/services/brig/src/Brig/IO/Intra.hs index df063cbdd0d..3a906829fea 100644 --- a/services/brig/src/Brig/IO/Intra.hs +++ b/services/brig/src/Brig/IO/Intra.hs @@ -121,7 +121,7 @@ import Wire.API.Federation.API.Brig import Wire.API.Federation.Client import Wire.API.Federation.Error (federationNotImplemented) import Wire.API.Message (UserClients) -import Wire.API.Team.Feature (TeamFeatureName (..), TeamFeatureStatus) +import Wire.API.Team.Feature (IncludeLockStatus (..), TeamFeatureName (..), TeamFeatureStatus) import Wire.API.Team.LegalHold (LegalholdProtectee) ----------------------------------------------------------------------------- @@ -968,7 +968,7 @@ getTeamName tid = do . expect2xx -- | Calls 'Galley.API.getTeamFeatureStatusH'. -getTeamLegalHoldStatus :: TeamId -> AppIO (TeamFeatureStatus 'TeamFeatureLegalHold) +getTeamLegalHoldStatus :: TeamId -> AppIO (TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureLegalHold) getTeamLegalHoldStatus tid = do debug $ remote "galley" . msg (val "Get legalhold settings") galleyRequest GET req >>= decodeBody "galley" diff --git a/services/brig/src/Brig/Options.hs b/services/brig/src/Brig/Options.hs index 7710b7608ef..874fd3a4a1c 100644 --- a/services/brig/src/Brig/Options.hs +++ b/services/brig/src/Brig/Options.hs @@ -508,8 +508,8 @@ data Settings = Settings -- they are grandfathered), and feature-specific extra data (eg., TLL for self-deleting -- messages). For now, we have something quick & simple. data AccountFeatureConfigs = AccountFeatureConfigs - { afcConferenceCallingDefNew :: !(ApiFT.TeamFeatureStatus 'ApiFT.TeamFeatureConferenceCalling), - afcConferenceCallingDefNull :: !(ApiFT.TeamFeatureStatus 'ApiFT.TeamFeatureConferenceCalling) + { afcConferenceCallingDefNew :: !(ApiFT.TeamFeatureStatus 'ApiFT.WithoutLockStatus 'ApiFT.TeamFeatureConferenceCalling), + afcConferenceCallingDefNull :: !(ApiFT.TeamFeatureStatus 'ApiFT.WithoutLockStatus 'ApiFT.TeamFeatureConferenceCalling) } deriving (Show, Eq, Generic) deriving (Arbitrary) via (GenericUniform AccountFeatureConfigs) diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index b1f68193ca3..d6247bd175b 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -437,6 +437,7 @@ executable galley-schema V52_FeatureConferenceCalling V53_AddRemoteConvStatus V54_TeamFeatureSelfDeletingMessages + V55_SelfDeletingMessagesLockStatus Paths_galley hs-source-dirs: schema/src diff --git a/services/galley/schema/src/Main.hs b/services/galley/schema/src/Main.hs index 369a4644368..e6bed347169 100644 --- a/services/galley/schema/src/Main.hs +++ b/services/galley/schema/src/Main.hs @@ -57,6 +57,7 @@ import qualified V51_FeatureFileSharing import qualified V52_FeatureConferenceCalling import qualified V53_AddRemoteConvStatus import qualified V54_TeamFeatureSelfDeletingMessages +import qualified V55_SelfDeletingMessagesLockStatus main :: IO () main = do @@ -99,9 +100,10 @@ main = do V51_FeatureFileSharing.migration, V52_FeatureConferenceCalling.migration, V53_AddRemoteConvStatus.migration, - V54_TeamFeatureSelfDeletingMessages.migration + V54_TeamFeatureSelfDeletingMessages.migration, + V55_SelfDeletingMessagesLockStatus.migration -- When adding migrations here, don't forget to update - -- 'schemaVersion' in Galley.Data + -- 'schemaVersion' in Galley.Cassandra -- (see also docs/developer/cassandra-interaction.md) -- -- FUTUREWORK: once #1726 has made its way to master/production, diff --git a/services/galley/schema/src/V55_SelfDeletingMessagesLockStatus.hs b/services/galley/schema/src/V55_SelfDeletingMessagesLockStatus.hs new file mode 100644 index 00000000000..58e61690693 --- /dev/null +++ b/services/galley/schema/src/V55_SelfDeletingMessagesLockStatus.hs @@ -0,0 +1,33 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2020 Wire Swiss GmbH +-- +-- 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 . + +module V55_SelfDeletingMessagesLockStatus + ( migration, + ) +where + +import Cassandra.Schema +import Imports +import Text.RawString.QQ + +migration :: Migration +migration = Migration 55 "Add payment status config for self deleting messages team feature" $ do + schema' + [r| ALTER TABLE team_features ADD ( + self_deleting_messages_lock_status int + ) + |] diff --git a/services/galley/src/Galley/API/Error.hs b/services/galley/src/Galley/API/Error.hs index 34c6ec0d3c8..2f49164b8ba 100644 --- a/services/galley/src/Galley/API/Error.hs +++ b/services/galley/src/Galley/API/Error.hs @@ -161,12 +161,14 @@ data TeamFeatureError | LegalHoldFeatureFlagNotEnabled | LegalHoldWhitelistedOnly | DisableSsoNotImplemented + | FeatureLocked instance APIError TeamFeatureError where toWai AppLockinactivityTimeoutTooLow = inactivityTimeoutTooLow toWai LegalHoldFeatureFlagNotEnabled = legalHoldFeatureFlagNotEnabled toWai LegalHoldWhitelistedOnly = legalHoldWhitelistedOnly toWai DisableSsoNotImplemented = disableSsoNotImplemented + toWai FeatureLocked = setTeamFeatureConfigFeatureLocked data TeamNotificationError = InvalidTeamNotificationId @@ -458,6 +460,9 @@ noLegalHoldDeviceAllocated = mkError status404 "legalhold-no-device-allocated" " legalHoldCouldNotBlockConnections :: Error legalHoldCouldNotBlockConnections = mkError status500 "legalhold-internal" "legal hold service: could not block connections when resolving policy conflicts." +setTeamFeatureConfigFeatureLocked :: Error +setTeamFeatureConfigFeatureLocked = mkError status409 "feature-locked" "feature config cannot be updated (eg., because it is configured to be locked, or because you need to upgrade your plan)" + disableSsoNotImplemented :: Error disableSsoNotImplemented = mkError diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index 5c5a555b927..5d870c0dddb 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -52,6 +52,7 @@ import Galley.API.Util import Galley.App import Galley.Cassandra.Paging import qualified Galley.Data.Conversation as Data +import Galley.Data.TeamFeatures (MaybeHasLockStatusCol) import Galley.Effects import Galley.Effects.ClientStore import Galley.Effects.ConversationStore @@ -121,79 +122,82 @@ data InternalApi routes = InternalApi -- Viewing the config for features should be allowed for any admin. iTeamFeatureStatusSSOGet :: routes - :- IFeatureStatusGet 'Public.TeamFeatureSSO, + :- IFeatureStatusGet 'Public.WithoutLockStatus 'Public.TeamFeatureSSO, iTeamFeatureStatusSSOPut :: routes :- IFeatureStatusPut 'Public.TeamFeatureSSO, iTeamFeatureStatusLegalHoldGet :: routes - :- IFeatureStatusGet 'Public.TeamFeatureLegalHold, + :- IFeatureStatusGet 'Public.WithoutLockStatus 'Public.TeamFeatureLegalHold, iTeamFeatureStatusLegalHoldPut :: routes :- IFeatureStatusPut 'Public.TeamFeatureLegalHold, iTeamFeatureStatusSearchVisibilityGet :: routes - :- IFeatureStatusGet 'Public.TeamFeatureSearchVisibility, + :- IFeatureStatusGet 'Public.WithoutLockStatus 'Public.TeamFeatureSearchVisibility, iTeamFeatureStatusSearchVisibilityPut :: routes :- IFeatureStatusPut 'Public.TeamFeatureSearchVisibility, iTeamFeatureStatusSearchVisibilityDeprecatedGet :: routes - :- IFeatureStatusDeprecatedGet 'Public.TeamFeatureSearchVisibility, + :- IFeatureStatusDeprecatedGet 'Public.WithoutLockStatus 'Public.TeamFeatureSearchVisibility, iTeamFeatureStatusSearchVisibilityDeprecatedPut :: routes :- IFeatureStatusDeprecatedPut 'Public.TeamFeatureSearchVisibility, iTeamFeatureStatusValidateSAMLEmailsGet :: routes - :- IFeatureStatusGet 'Public.TeamFeatureValidateSAMLEmails, + :- IFeatureStatusGet 'Public.WithoutLockStatus 'Public.TeamFeatureValidateSAMLEmails, iTeamFeatureStatusValidateSAMLEmailsPut :: routes :- IFeatureStatusPut 'Public.TeamFeatureValidateSAMLEmails, iTeamFeatureStatusValidateSAMLEmailsDeprecatedGet :: routes - :- IFeatureStatusDeprecatedGet 'Public.TeamFeatureValidateSAMLEmails, + :- IFeatureStatusDeprecatedGet 'Public.WithoutLockStatus 'Public.TeamFeatureValidateSAMLEmails, iTeamFeatureStatusValidateSAMLEmailsDeprecatedPut :: routes :- IFeatureStatusDeprecatedPut 'Public.TeamFeatureValidateSAMLEmails, iTeamFeatureStatusDigitalSignaturesGet :: routes - :- IFeatureStatusGet 'Public.TeamFeatureDigitalSignatures, + :- IFeatureStatusGet 'Public.WithoutLockStatus 'Public.TeamFeatureDigitalSignatures, iTeamFeatureStatusDigitalSignaturesPut :: routes :- IFeatureStatusPut 'Public.TeamFeatureDigitalSignatures, iTeamFeatureStatusDigitalSignaturesDeprecatedGet :: routes - :- IFeatureStatusDeprecatedGet 'Public.TeamFeatureDigitalSignatures, + :- IFeatureStatusDeprecatedGet 'Public.WithoutLockStatus 'Public.TeamFeatureDigitalSignatures, iTeamFeatureStatusDigitalSignaturesDeprecatedPut :: routes :- IFeatureStatusDeprecatedPut 'Public.TeamFeatureDigitalSignatures, iTeamFeatureStatusAppLockGet :: routes - :- IFeatureStatusGet 'Public.TeamFeatureAppLock, + :- IFeatureStatusGet 'Public.WithoutLockStatus 'Public.TeamFeatureAppLock, iTeamFeatureStatusAppLockPut :: routes :- IFeatureStatusPut 'Public.TeamFeatureAppLock, iTeamFeatureStatusFileSharingGet :: routes - :- IFeatureStatusGet 'Public.TeamFeatureFileSharing, + :- IFeatureStatusGet 'Public.WithoutLockStatus 'Public.TeamFeatureFileSharing, iTeamFeatureStatusFileSharingPut :: routes :- IFeatureStatusPut 'Public.TeamFeatureFileSharing, iTeamFeatureStatusClassifiedDomainsGet :: routes - :- IFeatureStatusGet 'Public.TeamFeatureClassifiedDomains, + :- IFeatureStatusGet 'Public.WithoutLockStatus 'Public.TeamFeatureClassifiedDomains, iTeamFeatureStatusConferenceCallingPut :: routes :- IFeatureStatusPut 'Public.TeamFeatureConferenceCalling, iTeamFeatureStatusConferenceCallingGet :: routes - :- IFeatureStatusGet 'Public.TeamFeatureConferenceCalling, + :- IFeatureStatusGet 'Public.WithoutLockStatus 'Public.TeamFeatureConferenceCalling, iTeamFeatureStatusSelfDeletingMessagesPut :: routes :- IFeatureStatusPut 'Public.TeamFeatureSelfDeletingMessages, iTeamFeatureStatusSelfDeletingMessagesGet :: routes - :- IFeatureStatusGet 'Public.TeamFeatureSelfDeletingMessages, + :- IFeatureStatusGet 'Public.WithLockStatus 'Public.TeamFeatureSelfDeletingMessages, + iTeamFeatureLockStatusSelfDeletingMessagesPut :: + routes + :- IFeatureStatusLockStatusPut 'Public.TeamFeatureSelfDeletingMessages, -- This endpoint can lead to the following events being sent: -- - MemberLeave event to members for all conversations the user was in iDeleteUser :: @@ -232,14 +236,14 @@ data InternalApi routes = InternalApi type ServantAPI = ToServantApi InternalApi -type IFeatureStatusGet featureName = +type IFeatureStatusGet lockStatus featureName = Summary (AppendSymbol "Get config for " (Public.KnownTeamFeatureNameSymbol featureName)) :> "i" :> "teams" :> Capture "tid" TeamId :> "features" :> Public.KnownTeamFeatureNameSymbol featureName - :> Get '[Servant.JSON] (Public.TeamFeatureStatus featureName) + :> Get '[Servant.JSON] (Public.TeamFeatureStatus lockStatus featureName) type IFeatureStatusPut featureName = Summary (AppendSymbol "Put config for " (Public.KnownTeamFeatureNameSymbol featureName)) @@ -248,18 +252,28 @@ type IFeatureStatusPut featureName = :> Capture "tid" TeamId :> "features" :> Public.KnownTeamFeatureNameSymbol featureName - :> ReqBody '[Servant.JSON] (Public.TeamFeatureStatus featureName) - :> Put '[Servant.JSON] (Public.TeamFeatureStatus featureName) + :> ReqBody '[Servant.JSON] (Public.TeamFeatureStatus 'Public.WithoutLockStatus featureName) + :> Put '[Servant.JSON] (Public.TeamFeatureStatus 'Public.WithoutLockStatus featureName) + +type IFeatureStatusLockStatusPut featureName = + Summary (AppendSymbol "(Un-)lock " (Public.KnownTeamFeatureNameSymbol featureName)) + :> "i" + :> "teams" + :> Capture "tid" TeamId + :> "features" + :> Public.KnownTeamFeatureNameSymbol featureName + :> Capture "lockStatus" Public.LockStatusValue + :> Put '[Servant.JSON] Public.LockStatus -- | A type for a GET endpoint for a feature with a deprecated path -type IFeatureStatusDeprecatedGet featureName = +type IFeatureStatusDeprecatedGet lockStatus featureName = Summary (AppendSymbol "[deprecated] Get config for " (Public.KnownTeamFeatureNameSymbol featureName)) :> "i" :> "teams" :> Capture "tid" TeamId :> "features" :> Public.DeprecatedFeatureName featureName - :> Get '[Servant.JSON] (Public.TeamFeatureStatus featureName) + :> Get '[Servant.JSON] (Public.TeamFeatureStatus lockStatus featureName) -- | A type for a PUT endpoint for a feature with a deprecated path type IFeatureStatusDeprecatedPut featureName = @@ -269,8 +283,8 @@ type IFeatureStatusDeprecatedPut featureName = :> Capture "tid" TeamId :> "features" :> Public.DeprecatedFeatureName featureName - :> ReqBody '[Servant.JSON] (Public.TeamFeatureStatus featureName) - :> Put '[Servant.JSON] (Public.TeamFeatureStatus featureName) + :> ReqBody '[Servant.JSON] (Public.TeamFeatureStatus 'Public.WithoutLockStatus featureName) + :> Put '[Servant.JSON] (Public.TeamFeatureStatus 'Public.WithoutLockStatus featureName) servantSitemap :: ServerT ServantAPI (Sem GalleyEffects) servantSitemap = @@ -278,38 +292,39 @@ servantSitemap = InternalApi { iStatusGet = pure NoContent, iStatusHead = pure NoContent, - iTeamFeatureStatusSSOGet = iGetTeamFeature @'Public.TeamFeatureSSO Features.getSSOStatusInternal, + iTeamFeatureStatusSSOGet = iGetTeamFeature @'Public.WithoutLockStatus @'Public.TeamFeatureSSO Features.getSSOStatusInternal, iTeamFeatureStatusSSOPut = iPutTeamFeature @'Public.TeamFeatureSSO Features.setSSOStatusInternal, - iTeamFeatureStatusLegalHoldGet = iGetTeamFeature @'Public.TeamFeatureLegalHold Features.getLegalholdStatusInternal, + iTeamFeatureStatusLegalHoldGet = iGetTeamFeature @'Public.WithoutLockStatus @'Public.TeamFeatureLegalHold Features.getLegalholdStatusInternal, iTeamFeatureStatusLegalHoldPut = iPutTeamFeature @'Public.TeamFeatureLegalHold (Features.setLegalholdStatusInternal @InternalPaging), - iTeamFeatureStatusSearchVisibilityGet = iGetTeamFeature @'Public.TeamFeatureSearchVisibility Features.getTeamSearchVisibilityAvailableInternal, + iTeamFeatureStatusSearchVisibilityGet = iGetTeamFeature @'Public.WithoutLockStatus @'Public.TeamFeatureSearchVisibility Features.getTeamSearchVisibilityAvailableInternal, iTeamFeatureStatusSearchVisibilityPut = iPutTeamFeature @'Public.TeamFeatureLegalHold Features.setTeamSearchVisibilityAvailableInternal, - iTeamFeatureStatusSearchVisibilityDeprecatedGet = iGetTeamFeature @'Public.TeamFeatureSearchVisibility Features.getTeamSearchVisibilityAvailableInternal, + iTeamFeatureStatusSearchVisibilityDeprecatedGet = iGetTeamFeature @'Public.WithoutLockStatus @'Public.TeamFeatureSearchVisibility Features.getTeamSearchVisibilityAvailableInternal, iTeamFeatureStatusSearchVisibilityDeprecatedPut = iPutTeamFeature @'Public.TeamFeatureLegalHold Features.setTeamSearchVisibilityAvailableInternal, - iTeamFeatureStatusValidateSAMLEmailsGet = iGetTeamFeature @'Public.TeamFeatureValidateSAMLEmails Features.getValidateSAMLEmailsInternal, + iTeamFeatureStatusValidateSAMLEmailsGet = iGetTeamFeature @'Public.WithoutLockStatus @'Public.TeamFeatureValidateSAMLEmails Features.getValidateSAMLEmailsInternal, iTeamFeatureStatusValidateSAMLEmailsPut = iPutTeamFeature @'Public.TeamFeatureValidateSAMLEmails Features.setValidateSAMLEmailsInternal, - iTeamFeatureStatusValidateSAMLEmailsDeprecatedGet = iGetTeamFeature @'Public.TeamFeatureValidateSAMLEmails Features.getValidateSAMLEmailsInternal, + iTeamFeatureStatusValidateSAMLEmailsDeprecatedGet = iGetTeamFeature @'Public.WithoutLockStatus @'Public.TeamFeatureValidateSAMLEmails Features.getValidateSAMLEmailsInternal, iTeamFeatureStatusValidateSAMLEmailsDeprecatedPut = iPutTeamFeature @'Public.TeamFeatureValidateSAMLEmails Features.setValidateSAMLEmailsInternal, - iTeamFeatureStatusDigitalSignaturesGet = iGetTeamFeature @'Public.TeamFeatureDigitalSignatures Features.getDigitalSignaturesInternal, + iTeamFeatureStatusDigitalSignaturesGet = iGetTeamFeature @'Public.WithoutLockStatus @'Public.TeamFeatureDigitalSignatures Features.getDigitalSignaturesInternal, iTeamFeatureStatusDigitalSignaturesPut = iPutTeamFeature @'Public.TeamFeatureDigitalSignatures Features.setDigitalSignaturesInternal, - iTeamFeatureStatusDigitalSignaturesDeprecatedGet = iGetTeamFeature @'Public.TeamFeatureDigitalSignatures Features.getDigitalSignaturesInternal, + iTeamFeatureStatusDigitalSignaturesDeprecatedGet = iGetTeamFeature @'Public.WithoutLockStatus @'Public.TeamFeatureDigitalSignatures Features.getDigitalSignaturesInternal, iTeamFeatureStatusDigitalSignaturesDeprecatedPut = iPutTeamFeature @'Public.TeamFeatureDigitalSignatures Features.setDigitalSignaturesInternal, - iTeamFeatureStatusAppLockGet = iGetTeamFeature @'Public.TeamFeatureAppLock Features.getAppLockInternal, + iTeamFeatureStatusAppLockGet = iGetTeamFeature @'Public.WithoutLockStatus @'Public.TeamFeatureAppLock Features.getAppLockInternal, iTeamFeatureStatusAppLockPut = iPutTeamFeature @'Public.TeamFeatureAppLock Features.setAppLockInternal, - iTeamFeatureStatusFileSharingGet = iGetTeamFeature @'Public.TeamFeatureFileSharing Features.getFileSharingInternal, + iTeamFeatureStatusFileSharingGet = iGetTeamFeature @'Public.WithoutLockStatus @'Public.TeamFeatureFileSharing Features.getFileSharingInternal, iTeamFeatureStatusFileSharingPut = iPutTeamFeature @'Public.TeamFeatureFileSharing Features.setFileSharingInternal, - iTeamFeatureStatusClassifiedDomainsGet = iGetTeamFeature @'Public.TeamFeatureClassifiedDomains Features.getClassifiedDomainsInternal, + iTeamFeatureStatusClassifiedDomainsGet = iGetTeamFeature @'Public.WithoutLockStatus @'Public.TeamFeatureClassifiedDomains Features.getClassifiedDomainsInternal, iTeamFeatureStatusConferenceCallingPut = iPutTeamFeature @'Public.TeamFeatureConferenceCalling Features.setConferenceCallingInternal, - iTeamFeatureStatusConferenceCallingGet = iGetTeamFeature @'Public.TeamFeatureConferenceCalling Features.getConferenceCallingInternal, + iTeamFeatureStatusConferenceCallingGet = iGetTeamFeature @'Public.WithoutLockStatus @'Public.TeamFeatureConferenceCalling Features.getConferenceCallingInternal, iTeamFeatureStatusSelfDeletingMessagesPut = iPutTeamFeature @'Public.TeamFeatureSelfDeletingMessages Features.setSelfDeletingMessagesInternal, - iTeamFeatureStatusSelfDeletingMessagesGet = iGetTeamFeature @'Public.TeamFeatureSelfDeletingMessages Features.getSelfDeletingMessagesInternal, + iTeamFeatureStatusSelfDeletingMessagesGet = iGetTeamFeature @'Public.WithLockStatus @'Public.TeamFeatureSelfDeletingMessages Features.getSelfDeletingMessagesInternal, + iTeamFeatureLockStatusSelfDeletingMessagesPut = Features.setLockStatus @'Public.TeamFeatureSelfDeletingMessages, iDeleteUser = rmUser, iConnect = Create.createConnectConversation, iUpsertOne2OneConversation = One2One.iUpsertOne2OneConversation } iGetTeamFeature :: - forall a r. + forall ps a r. ( Public.KnownTeamFeatureName a, Members '[ Error ActionError, @@ -319,26 +334,29 @@ iGetTeamFeature :: ] r ) => - (Features.GetFeatureInternalParam -> Sem r (Public.TeamFeatureStatus a)) -> + (Features.GetFeatureInternalParam -> Sem r (Public.TeamFeatureStatus ps a)) -> TeamId -> - Sem r (Public.TeamFeatureStatus a) -iGetTeamFeature getter = Features.getFeatureStatus @a getter DontDoAuth + Sem r (Public.TeamFeatureStatus ps a) +iGetTeamFeature getter = Features.getFeatureStatus @ps @a getter DontDoAuth iPutTeamFeature :: forall a r. ( Public.KnownTeamFeatureName a, + MaybeHasLockStatusCol a, Members '[ Error ActionError, Error NotATeamMember, Error TeamError, - TeamStore + Error TeamFeatureError, + TeamStore, + TeamFeatureStore ] r ) => - (TeamId -> Public.TeamFeatureStatus a -> Sem r (Public.TeamFeatureStatus a)) -> + (TeamId -> Public.TeamFeatureStatus 'Public.WithoutLockStatus a -> Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus a)) -> TeamId -> - Public.TeamFeatureStatus a -> - Sem r (Public.TeamFeatureStatus a) + Public.TeamFeatureStatus 'Public.WithoutLockStatus a -> + Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus a) iPutTeamFeature setter = Features.setFeatureStatus @a setter DontDoAuth sitemap :: Routes a (Sem GalleyEffects) () @@ -581,7 +599,7 @@ rmUser lusr conn = do for_ (maybeList1 (catMaybes pp)) - (push) + push -- FUTUREWORK: This could be optimized to reduce the number of RPCs -- made. When a team is deleted the burst of RPCs created here could diff --git a/services/galley/src/Galley/API/LegalHold.hs b/services/galley/src/Galley/API/LegalHold.hs index 5bbe62a2362..051d82c30a2 100644 --- a/services/galley/src/Galley/API/LegalHold.hs +++ b/services/galley/src/Galley/API/LegalHold.hs @@ -103,7 +103,7 @@ isLegalHoldEnabledForTeam tid = do pure False FeatureLegalHoldDisabledByDefault -> do statusValue <- - Public.tfwoStatus <$$> TeamFeatures.getFeatureStatusNoConfig @'Public.TeamFeatureLegalHold tid + Public.tfwoStatus <$$> TeamFeatures.getFeatureStatusNoConfig @'Public.WithoutLockStatus @'Public.TeamFeatureLegalHold tid return $ case statusValue of Just Public.TeamFeatureEnabled -> True Just Public.TeamFeatureDisabled -> False diff --git a/services/galley/src/Galley/API/Public.hs b/services/galley/src/Galley/API/Public.hs index 3027ba070ab..fa6eb5e7a56 100644 --- a/services/galley/src/Galley/API/Public.hs +++ b/services/galley/src/Galley/API/Public.hs @@ -117,70 +117,70 @@ servantSitemap = GalleyAPI.postOtrMessageUnqualified = Update.postOtrMessageUnqualified, GalleyAPI.postProteusMessage = Update.postProteusMessage, GalleyAPI.teamFeatureStatusSSOGet = - getFeatureStatus @'Public.TeamFeatureSSO Features.getSSOStatusInternal + getFeatureStatus @'Public.WithoutLockStatus @'Public.TeamFeatureSSO Features.getSSOStatusInternal . DoAuth, GalleyAPI.teamFeatureStatusLegalHoldGet = - getFeatureStatus @'Public.TeamFeatureLegalHold Features.getLegalholdStatusInternal + getFeatureStatus @'Public.WithoutLockStatus @'Public.TeamFeatureLegalHold Features.getLegalholdStatusInternal . DoAuth, GalleyAPI.teamFeatureStatusLegalHoldPut = setFeatureStatus @'Public.TeamFeatureLegalHold (Features.setLegalholdStatusInternal @InternalPaging) . DoAuth, GalleyAPI.teamFeatureStatusSearchVisibilityGet = - getFeatureStatus @'Public.TeamFeatureSearchVisibility Features.getTeamSearchVisibilityAvailableInternal + getFeatureStatus @'Public.WithoutLockStatus @'Public.TeamFeatureSearchVisibility Features.getTeamSearchVisibilityAvailableInternal . DoAuth, GalleyAPI.teamFeatureStatusSearchVisibilityPut = setFeatureStatus @'Public.TeamFeatureSearchVisibility Features.setTeamSearchVisibilityAvailableInternal . DoAuth, GalleyAPI.teamFeatureStatusSearchVisibilityDeprecatedGet = - getFeatureStatus @'Public.TeamFeatureSearchVisibility Features.getTeamSearchVisibilityAvailableInternal + getFeatureStatus @'Public.WithoutLockStatus @'Public.TeamFeatureSearchVisibility Features.getTeamSearchVisibilityAvailableInternal . DoAuth, GalleyAPI.teamFeatureStatusSearchVisibilityDeprecatedPut = setFeatureStatus @'Public.TeamFeatureSearchVisibility Features.setTeamSearchVisibilityAvailableInternal . DoAuth, GalleyAPI.teamFeatureStatusValidateSAMLEmailsGet = - getFeatureStatus @'Public.TeamFeatureValidateSAMLEmails Features.getValidateSAMLEmailsInternal + getFeatureStatus @'Public.WithoutLockStatus @'Public.TeamFeatureValidateSAMLEmails Features.getValidateSAMLEmailsInternal . DoAuth, GalleyAPI.teamFeatureStatusValidateSAMLEmailsDeprecatedGet = - getFeatureStatus @'Public.TeamFeatureValidateSAMLEmails Features.getValidateSAMLEmailsInternal + getFeatureStatus @'Public.WithoutLockStatus @'Public.TeamFeatureValidateSAMLEmails Features.getValidateSAMLEmailsInternal . DoAuth, GalleyAPI.teamFeatureStatusDigitalSignaturesGet = - getFeatureStatus @'Public.TeamFeatureDigitalSignatures Features.getDigitalSignaturesInternal + getFeatureStatus @'Public.WithoutLockStatus @'Public.TeamFeatureDigitalSignatures Features.getDigitalSignaturesInternal . DoAuth, GalleyAPI.teamFeatureStatusDigitalSignaturesDeprecatedGet = - getFeatureStatus @'Public.TeamFeatureDigitalSignatures Features.getDigitalSignaturesInternal + getFeatureStatus @'Public.WithoutLockStatus @'Public.TeamFeatureDigitalSignatures Features.getDigitalSignaturesInternal . DoAuth, GalleyAPI.teamFeatureStatusAppLockGet = - getFeatureStatus @'Public.TeamFeatureAppLock Features.getAppLockInternal + getFeatureStatus @'Public.WithoutLockStatus @'Public.TeamFeatureAppLock Features.getAppLockInternal . DoAuth, GalleyAPI.teamFeatureStatusAppLockPut = setFeatureStatus @'Public.TeamFeatureAppLock Features.setAppLockInternal . DoAuth, GalleyAPI.teamFeatureStatusFileSharingGet = - getFeatureStatus @'Public.TeamFeatureFileSharing Features.getFileSharingInternal . DoAuth, + getFeatureStatus @'Public.WithoutLockStatus @'Public.TeamFeatureFileSharing Features.getFileSharingInternal . DoAuth, GalleyAPI.teamFeatureStatusFileSharingPut = setFeatureStatus @'Public.TeamFeatureFileSharing Features.setFileSharingInternal . DoAuth, GalleyAPI.teamFeatureStatusClassifiedDomainsGet = - getFeatureStatus @'Public.TeamFeatureClassifiedDomains Features.getClassifiedDomainsInternal + getFeatureStatus @'Public.WithoutLockStatus @'Public.TeamFeatureClassifiedDomains Features.getClassifiedDomainsInternal . DoAuth, GalleyAPI.teamFeatureStatusConferenceCallingGet = - getFeatureStatus @'Public.TeamFeatureConferenceCalling Features.getConferenceCallingInternal + getFeatureStatus @'Public.WithoutLockStatus @'Public.TeamFeatureConferenceCalling Features.getConferenceCallingInternal . DoAuth, GalleyAPI.teamFeatureStatusSelfDeletingMessagesGet = - getFeatureStatus @'Public.TeamFeatureSelfDeletingMessages Features.getSelfDeletingMessagesInternal + getFeatureStatus @'Public.WithLockStatus @'Public.TeamFeatureSelfDeletingMessages Features.getSelfDeletingMessagesInternal . DoAuth, GalleyAPI.teamFeatureStatusSelfDeletingMessagesPut = setFeatureStatus @'Public.TeamFeatureSelfDeletingMessages Features.setSelfDeletingMessagesInternal . DoAuth, GalleyAPI.featureAllFeatureConfigsGet = Features.getAllFeatureConfigs, - GalleyAPI.featureConfigLegalHoldGet = Features.getFeatureConfig @'Public.TeamFeatureLegalHold Features.getLegalholdStatusInternal, - GalleyAPI.featureConfigSSOGet = Features.getFeatureConfig @'Public.TeamFeatureSSO Features.getSSOStatusInternal, - GalleyAPI.featureConfigSearchVisibilityGet = Features.getFeatureConfig @'Public.TeamFeatureSearchVisibility Features.getTeamSearchVisibilityAvailableInternal, - GalleyAPI.featureConfigValidateSAMLEmailsGet = Features.getFeatureConfig @'Public.TeamFeatureValidateSAMLEmails Features.getValidateSAMLEmailsInternal, - GalleyAPI.featureConfigDigitalSignaturesGet = Features.getFeatureConfig @'Public.TeamFeatureDigitalSignatures Features.getDigitalSignaturesInternal, - GalleyAPI.featureConfigAppLockGet = Features.getFeatureConfig @'Public.TeamFeatureAppLock Features.getAppLockInternal, - GalleyAPI.featureConfigFileSharingGet = Features.getFeatureConfig @'Public.TeamFeatureFileSharing Features.getFileSharingInternal, - GalleyAPI.featureConfigClassifiedDomainsGet = Features.getFeatureConfig @'Public.TeamFeatureClassifiedDomains Features.getClassifiedDomainsInternal, - GalleyAPI.featureConfigConferenceCallingGet = Features.getFeatureConfig @'Public.TeamFeatureConferenceCalling Features.getConferenceCallingInternal, - GalleyAPI.featureConfigSelfDeletingMessagesGet = Features.getFeatureConfig @'Public.TeamFeatureSelfDeletingMessages Features.getSelfDeletingMessagesInternal + GalleyAPI.featureConfigLegalHoldGet = Features.getFeatureConfig @'Public.WithoutLockStatus @'Public.TeamFeatureLegalHold Features.getLegalholdStatusInternal, + GalleyAPI.featureConfigSSOGet = Features.getFeatureConfig @'Public.WithoutLockStatus @'Public.TeamFeatureSSO Features.getSSOStatusInternal, + GalleyAPI.featureConfigSearchVisibilityGet = Features.getFeatureConfig @'Public.WithoutLockStatus @'Public.TeamFeatureSearchVisibility Features.getTeamSearchVisibilityAvailableInternal, + GalleyAPI.featureConfigValidateSAMLEmailsGet = Features.getFeatureConfig @'Public.WithoutLockStatus @'Public.TeamFeatureValidateSAMLEmails Features.getValidateSAMLEmailsInternal, + GalleyAPI.featureConfigDigitalSignaturesGet = Features.getFeatureConfig @'Public.WithoutLockStatus @'Public.TeamFeatureDigitalSignatures Features.getDigitalSignaturesInternal, + GalleyAPI.featureConfigAppLockGet = Features.getFeatureConfig @'Public.WithoutLockStatus @'Public.TeamFeatureAppLock Features.getAppLockInternal, + GalleyAPI.featureConfigFileSharingGet = Features.getFeatureConfig @'Public.WithoutLockStatus @'Public.TeamFeatureFileSharing Features.getFileSharingInternal, + GalleyAPI.featureConfigClassifiedDomainsGet = Features.getFeatureConfig @'Public.WithoutLockStatus @'Public.TeamFeatureClassifiedDomains Features.getClassifiedDomainsInternal, + GalleyAPI.featureConfigConferenceCallingGet = Features.getFeatureConfig @'Public.WithoutLockStatus @'Public.TeamFeatureConferenceCalling Features.getConferenceCallingInternal, + GalleyAPI.featureConfigSelfDeletingMessagesGet = Features.getFeatureConfig @'Public.WithLockStatus @'Public.TeamFeatureSelfDeletingMessages Features.getSelfDeletingMessagesInternal } sitemap :: Routes ApiBuilder (Sem GalleyEffects) () diff --git a/services/galley/src/Galley/API/Teams.hs b/services/galley/src/Galley/API/Teams.hs index ce9b1ef65ba..5f06956348c 100644 --- a/services/galley/src/Galley/API/Teams.hs +++ b/services/galley/src/Galley/API/Teams.hs @@ -1522,7 +1522,7 @@ canUserJoinTeam tid = do getTeamSearchVisibilityAvailableInternal :: Members '[Input Opts, TeamFeatureStore] r => TeamId -> - Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureSearchVisibility) + Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureSearchVisibility) getTeamSearchVisibilityAvailableInternal tid = do -- TODO: This is just redundant given there is a decent default defConfig <- do @@ -1532,7 +1532,7 @@ getTeamSearchVisibilityAvailableInternal tid = do FeatureTeamSearchVisibilityDisabledByDefault -> Public.TeamFeatureDisabled fromMaybe defConfig - <$> TeamFeatures.getFeatureStatusNoConfig @'Public.TeamFeatureSearchVisibility tid + <$> TeamFeatures.getFeatureStatusNoConfig @'Public.WithoutLockStatus @'Public.TeamFeatureSearchVisibility tid -- | Modify and get visibility type for a team (internal, no user permission checks) getSearchVisibilityInternalH :: diff --git a/services/galley/src/Galley/API/Teams/Features.hs b/services/galley/src/Galley/API/Teams/Features.hs index 19e49f76b1b..9c1650a29bb 100644 --- a/services/galley/src/Galley/API/Teams/Features.hs +++ b/services/galley/src/Galley/API/Teams/Features.hs @@ -40,6 +40,7 @@ module Galley.API.Teams.Features setConferenceCallingInternal, getSelfDeletingMessagesInternal, setSelfDeletingMessagesInternal, + setLockStatus, DoAuth (..), GetFeatureInternalParam, ) @@ -90,7 +91,7 @@ data DoAuth = DoAuth UserId | DontDoAuth -- | For team-settings, to administrate team feature configuration. Here we have an admin uid -- and a team id, but no uid of the member for which the feature config holds. getFeatureStatus :: - forall (a :: Public.TeamFeatureName) r. + forall (ps :: Public.IncludeLockStatus) (a :: Public.TeamFeatureName) r. ( Public.KnownTeamFeatureName a, Members '[ Error ActionError, @@ -100,10 +101,10 @@ getFeatureStatus :: ] r ) => - (GetFeatureInternalParam -> Sem r (Public.TeamFeatureStatus a)) -> + (GetFeatureInternalParam -> Sem r (Public.TeamFeatureStatus ps a)) -> DoAuth -> TeamId -> - Sem r (Public.TeamFeatureStatus a) + Sem r (Public.TeamFeatureStatus ps a) getFeatureStatus getter doauth tid = do case doauth of DoAuth uid -> do @@ -117,19 +118,21 @@ getFeatureStatus getter doauth tid = do setFeatureStatus :: forall (a :: Public.TeamFeatureName) r. ( Public.KnownTeamFeatureName a, + MaybeHasLockStatusCol a, Members '[ Error ActionError, Error TeamError, Error NotATeamMember, - TeamStore + TeamStore, + TeamFeatureStore ] r ) => - (TeamId -> Public.TeamFeatureStatus a -> Sem r (Public.TeamFeatureStatus a)) -> + (TeamId -> Public.TeamFeatureStatus 'Public.WithoutLockStatus a -> Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus a)) -> DoAuth -> TeamId -> - Public.TeamFeatureStatus a -> - Sem r (Public.TeamFeatureStatus a) + Public.TeamFeatureStatus 'Public.WithoutLockStatus a -> + Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus a) setFeatureStatus setter doauth tid status = do case doauth of DoAuth uid -> do @@ -139,9 +142,30 @@ setFeatureStatus setter doauth tid status = do assertTeamExists tid setter tid status +-- | Setting lock status can only be done through the internal API and therefore doesn't require auth. +setLockStatus :: + forall (a :: Public.TeamFeatureName) r. + ( Public.KnownTeamFeatureName a, + HasLockStatusCol a, + Members + [ Error ActionError, + Error TeamError, + Error NotATeamMember, + TeamStore, + TeamFeatureStore + ] + r + ) => + TeamId -> + Public.LockStatusValue -> + Sem r Public.LockStatus +setLockStatus tid lockStatusUpdate = do + assertTeamExists tid + TeamFeatures.setLockStatus @a tid (Public.LockStatus lockStatusUpdate) + -- | For individual users to get feature config for their account (personal or team). getFeatureConfig :: - forall (a :: Public.TeamFeatureName) r. + forall (ps :: Public.IncludeLockStatus) (a :: Public.TeamFeatureName) r. ( Public.KnownTeamFeatureName a, Members '[ Error ActionError, @@ -151,9 +175,9 @@ getFeatureConfig :: ] r ) => - (GetFeatureInternalParam -> Sem r (Public.TeamFeatureStatus a)) -> + (GetFeatureInternalParam -> Sem r (Public.TeamFeatureStatus ps a)) -> UserId -> - Sem r (Public.TeamFeatureStatus a) + Sem r (Public.TeamFeatureStatus ps a) getFeatureConfig getter zusr = do mbTeam <- getOneUserTeam zusr case mbTeam of @@ -180,34 +204,34 @@ getAllFeatureConfigs :: Sem r AllFeatureConfigs getAllFeatureConfigs zusr = do mbTeam <- getOneUserTeam zusr - zusrMembership <- maybe (pure Nothing) ((flip getTeamMember zusr)) mbTeam + zusrMembership <- maybe (pure Nothing) (flip getTeamMember zusr) mbTeam let getStatus :: - forall (a :: Public.TeamFeatureName) r. + forall (ps :: Public.IncludeLockStatus) (a :: Public.TeamFeatureName) r. ( Public.KnownTeamFeatureName a, - Aeson.ToJSON (Public.TeamFeatureStatus a), + Aeson.ToJSON (Public.TeamFeatureStatus ps a), Members '[Error ActionError, Error TeamError, Error NotATeamMember, TeamStore] r ) => - (GetFeatureInternalParam -> Sem r (Public.TeamFeatureStatus a)) -> + (GetFeatureInternalParam -> Sem r (Public.TeamFeatureStatus ps a)) -> Sem r (Text, Aeson.Value) getStatus getter = do when (isJust mbTeam) $ do void $ permissionCheck (ViewTeamFeature (Public.knownTeamFeatureName @a)) zusrMembership status <- getter (maybe (Left (Just zusr)) Right mbTeam) let feature = Public.knownTeamFeatureName @a - pure $ (cs (toByteString' feature) Aeson..= status) + pure $ cs (toByteString' feature) Aeson..= status AllFeatureConfigs . HashMap.fromList <$> sequence - [ getStatus @'Public.TeamFeatureLegalHold getLegalholdStatusInternal, - getStatus @'Public.TeamFeatureSSO getSSOStatusInternal, - getStatus @'Public.TeamFeatureSearchVisibility getTeamSearchVisibilityAvailableInternal, - getStatus @'Public.TeamFeatureValidateSAMLEmails getValidateSAMLEmailsInternal, - getStatus @'Public.TeamFeatureDigitalSignatures getDigitalSignaturesInternal, - getStatus @'Public.TeamFeatureAppLock getAppLockInternal, - getStatus @'Public.TeamFeatureFileSharing getFileSharingInternal, - getStatus @'Public.TeamFeatureClassifiedDomains getClassifiedDomainsInternal, - getStatus @'Public.TeamFeatureConferenceCalling getConferenceCallingInternal, - getStatus @'Public.TeamFeatureSelfDeletingMessages getSelfDeletingMessagesInternal + [ getStatus @'Public.WithoutLockStatus @'Public.TeamFeatureLegalHold getLegalholdStatusInternal, + getStatus @'Public.WithoutLockStatus @'Public.TeamFeatureSSO getSSOStatusInternal, + getStatus @'Public.WithoutLockStatus @'Public.TeamFeatureSearchVisibility getTeamSearchVisibilityAvailableInternal, + getStatus @'Public.WithoutLockStatus @'Public.TeamFeatureValidateSAMLEmails getValidateSAMLEmailsInternal, + getStatus @'Public.WithoutLockStatus @'Public.TeamFeatureDigitalSignatures getDigitalSignaturesInternal, + getStatus @'Public.WithoutLockStatus @'Public.TeamFeatureAppLock getAppLockInternal, + getStatus @'Public.WithoutLockStatus @'Public.TeamFeatureFileSharing getFileSharingInternal, + getStatus @'Public.WithoutLockStatus @'Public.TeamFeatureClassifiedDomains getClassifiedDomainsInternal, + getStatus @'Public.WithoutLockStatus @'Public.TeamFeatureConferenceCalling getConferenceCallingInternal, + getStatus @'Public.WithLockStatus @'Public.TeamFeatureSelfDeletingMessages getSelfDeletingMessagesInternal ] getAllFeaturesH :: @@ -246,57 +270,57 @@ getAllFeatures :: getAllFeatures uid tid = do Aeson.object <$> sequence - [ getStatus @'Public.TeamFeatureSSO getSSOStatusInternal, - getStatus @'Public.TeamFeatureLegalHold getLegalholdStatusInternal, - getStatus @'Public.TeamFeatureSearchVisibility getTeamSearchVisibilityAvailableInternal, - getStatus @'Public.TeamFeatureValidateSAMLEmails getValidateSAMLEmailsInternal, - getStatus @'Public.TeamFeatureDigitalSignatures getDigitalSignaturesInternal, - getStatus @'Public.TeamFeatureAppLock getAppLockInternal, - getStatus @'Public.TeamFeatureFileSharing getFileSharingInternal, - getStatus @'Public.TeamFeatureClassifiedDomains getClassifiedDomainsInternal, - getStatus @'Public.TeamFeatureConferenceCalling getConferenceCallingInternal, - getStatus @'Public.TeamFeatureSelfDeletingMessages getSelfDeletingMessagesInternal + [ getStatus @'Public.WithoutLockStatus @'Public.TeamFeatureSSO getSSOStatusInternal, + getStatus @'Public.WithoutLockStatus @'Public.TeamFeatureLegalHold getLegalholdStatusInternal, + getStatus @'Public.WithoutLockStatus @'Public.TeamFeatureSearchVisibility getTeamSearchVisibilityAvailableInternal, + getStatus @'Public.WithoutLockStatus @'Public.TeamFeatureValidateSAMLEmails getValidateSAMLEmailsInternal, + getStatus @'Public.WithoutLockStatus @'Public.TeamFeatureDigitalSignatures getDigitalSignaturesInternal, + getStatus @'Public.WithoutLockStatus @'Public.TeamFeatureAppLock getAppLockInternal, + getStatus @'Public.WithoutLockStatus @'Public.TeamFeatureFileSharing getFileSharingInternal, + getStatus @'Public.WithoutLockStatus @'Public.TeamFeatureClassifiedDomains getClassifiedDomainsInternal, + getStatus @'Public.WithoutLockStatus @'Public.TeamFeatureConferenceCalling getConferenceCallingInternal, + getStatus @'Public.WithLockStatus @'Public.TeamFeatureSelfDeletingMessages getSelfDeletingMessagesInternal ] where getStatus :: - forall (a :: Public.TeamFeatureName). + forall (ps :: Public.IncludeLockStatus) (a :: Public.TeamFeatureName). ( Public.KnownTeamFeatureName a, - Aeson.ToJSON (Public.TeamFeatureStatus a) + Aeson.ToJSON (Public.TeamFeatureStatus ps a) ) => - (GetFeatureInternalParam -> Sem r (Public.TeamFeatureStatus a)) -> + (GetFeatureInternalParam -> Sem r (Public.TeamFeatureStatus ps a)) -> Sem r (Text, Aeson.Value) getStatus getter = do - status <- getFeatureStatus @a getter (DoAuth uid) tid + status <- getFeatureStatus @ps @a getter (DoAuth uid) tid let feature = Public.knownTeamFeatureName @a - pure $ (cs (toByteString' feature) Aeson..= status) + pure $ cs (toByteString' feature) Aeson..= status getFeatureStatusNoConfig :: - forall (a :: Public.TeamFeatureName) r. - ( Public.FeatureHasNoConfig a, + forall (ps :: Public.IncludeLockStatus) (a :: Public.TeamFeatureName) r. + ( Public.FeatureHasNoConfig ps a, HasStatusCol a, Member TeamFeatureStore r ) => Sem r Public.TeamFeatureStatusValue -> TeamId -> - Sem r (Public.TeamFeatureStatus a) + Sem r (Public.TeamFeatureStatus ps a) getFeatureStatusNoConfig getDefault tid = do defaultStatus <- Public.TeamFeatureStatusNoConfig <$> getDefault - fromMaybe defaultStatus <$> TeamFeatures.getFeatureStatusNoConfig @a tid + fromMaybe defaultStatus <$> TeamFeatures.getFeatureStatusNoConfig @ps @a tid setFeatureStatusNoConfig :: - forall (a :: Public.TeamFeatureName) r. + forall (ps :: Public.IncludeLockStatus) (a :: Public.TeamFeatureName) r. ( Public.KnownTeamFeatureName a, - Public.FeatureHasNoConfig a, + Public.FeatureHasNoConfig ps a, HasStatusCol a, Members '[GundeckAccess, TeamFeatureStore, TeamStore, P.TinyLog] r ) => (Public.TeamFeatureStatusValue -> TeamId -> Sem r ()) -> TeamId -> - Public.TeamFeatureStatus a -> - Sem r (Public.TeamFeatureStatus a) + Public.TeamFeatureStatus ps a -> + Sem r (Public.TeamFeatureStatus ps a) setFeatureStatusNoConfig applyState tid status = do applyState (Public.tfwoStatus status) tid - newStatus <- TeamFeatures.setFeatureStatusNoConfig @a tid status + newStatus <- TeamFeatures.setFeatureStatusNoConfig @ps @a tid status pushFeatureConfigEvent tid $ Event.Event Event.Update (Public.knownTeamFeatureName @a) (EdFeatureWithoutConfigChanged newStatus) pure newStatus @@ -308,11 +332,11 @@ type GetFeatureInternalParam = Either (Maybe UserId) TeamId getSSOStatusInternal :: Members '[Input Opts, TeamFeatureStore] r => GetFeatureInternalParam -> - Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureSSO) + Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureSSO) getSSOStatusInternal = either (const $ Public.TeamFeatureStatusNoConfig <$> getDef) - (getFeatureStatusNoConfig @'Public.TeamFeatureSSO getDef) + (getFeatureStatusNoConfig @'Public.WithoutLockStatus @'Public.TeamFeatureSSO getDef) where getDef :: Member (Input Opts) r => Sem r Public.TeamFeatureStatusValue getDef = @@ -323,20 +347,20 @@ getSSOStatusInternal = setSSOStatusInternal :: Members '[Error TeamFeatureError, GundeckAccess, TeamFeatureStore, TeamStore, P.TinyLog] r => TeamId -> - (Public.TeamFeatureStatus 'Public.TeamFeatureSSO) -> - Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureSSO) -setSSOStatusInternal = setFeatureStatusNoConfig @'Public.TeamFeatureSSO $ \case + Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureSSO -> + Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureSSO) +setSSOStatusInternal = setFeatureStatusNoConfig @'Public.WithoutLockStatus @'Public.TeamFeatureSSO $ \case Public.TeamFeatureDisabled -> const (throw DisableSsoNotImplemented) Public.TeamFeatureEnabled -> const (pure ()) getTeamSearchVisibilityAvailableInternal :: Members '[Input Opts, TeamFeatureStore] r => GetFeatureInternalParam -> - Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureSearchVisibility) + Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureSearchVisibility) getTeamSearchVisibilityAvailableInternal = either (const $ Public.TeamFeatureStatusNoConfig <$> getDef) - (getFeatureStatusNoConfig @'Public.TeamFeatureSearchVisibility getDef) + (getFeatureStatusNoConfig @'Public.WithoutLockStatus @'Public.TeamFeatureSearchVisibility getDef) where getDef = do inputs (view (optSettings . setFeatureFlags . flagTeamSearchVisibility)) <&> \case @@ -346,20 +370,20 @@ getTeamSearchVisibilityAvailableInternal = setTeamSearchVisibilityAvailableInternal :: Members '[GundeckAccess, SearchVisibilityStore, TeamFeatureStore, TeamStore, P.TinyLog] r => TeamId -> - (Public.TeamFeatureStatus 'Public.TeamFeatureSearchVisibility) -> - Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureSearchVisibility) -setTeamSearchVisibilityAvailableInternal = setFeatureStatusNoConfig @'Public.TeamFeatureSearchVisibility $ \case + Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureSearchVisibility -> + Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureSearchVisibility) +setTeamSearchVisibilityAvailableInternal = setFeatureStatusNoConfig @'Public.WithoutLockStatus @'Public.TeamFeatureSearchVisibility $ \case Public.TeamFeatureDisabled -> SearchVisibilityData.resetSearchVisibility Public.TeamFeatureEnabled -> const (pure ()) getValidateSAMLEmailsInternal :: Member TeamFeatureStore r => GetFeatureInternalParam -> - Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureValidateSAMLEmails) + Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureValidateSAMLEmails) getValidateSAMLEmailsInternal = either (const $ Public.TeamFeatureStatusNoConfig <$> getDef) - (getFeatureStatusNoConfig @'Public.TeamFeatureValidateSAMLEmails getDef) + (getFeatureStatusNoConfig @'Public.WithoutLockStatus @'Public.TeamFeatureValidateSAMLEmails getDef) where -- FUTUREWORK: we may also want to get a default from the server config file here, like for -- sso, and team search visibility. @@ -369,18 +393,18 @@ getValidateSAMLEmailsInternal = setValidateSAMLEmailsInternal :: Members '[GundeckAccess, TeamFeatureStore, TeamStore, P.TinyLog] r => TeamId -> - (Public.TeamFeatureStatus 'Public.TeamFeatureValidateSAMLEmails) -> - Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureValidateSAMLEmails) -setValidateSAMLEmailsInternal = setFeatureStatusNoConfig @'Public.TeamFeatureValidateSAMLEmails $ \_ _ -> pure () + Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureValidateSAMLEmails -> + Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureValidateSAMLEmails) +setValidateSAMLEmailsInternal = setFeatureStatusNoConfig @'Public.WithoutLockStatus @'Public.TeamFeatureValidateSAMLEmails $ \_ _ -> pure () getDigitalSignaturesInternal :: Member TeamFeatureStore r => GetFeatureInternalParam -> - Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureDigitalSignatures) + Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureDigitalSignatures) getDigitalSignaturesInternal = either (const $ Public.TeamFeatureStatusNoConfig <$> getDef) - (getFeatureStatusNoConfig @'Public.TeamFeatureDigitalSignatures getDef) + (getFeatureStatusNoConfig @'Public.WithoutLockStatus @'Public.TeamFeatureDigitalSignatures getDef) where -- FUTUREWORK: we may also want to get a default from the server config file here, like for -- sso, and team search visibility. @@ -390,14 +414,14 @@ getDigitalSignaturesInternal = setDigitalSignaturesInternal :: Members '[GundeckAccess, TeamFeatureStore, TeamStore, P.TinyLog] r => TeamId -> - Public.TeamFeatureStatus 'Public.TeamFeatureDigitalSignatures -> - Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureDigitalSignatures) -setDigitalSignaturesInternal = setFeatureStatusNoConfig @'Public.TeamFeatureDigitalSignatures $ \_ _ -> pure () + Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureDigitalSignatures -> + Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureDigitalSignatures) +setDigitalSignaturesInternal = setFeatureStatusNoConfig @'Public.WithoutLockStatus @'Public.TeamFeatureDigitalSignatures $ \_ _ -> pure () getLegalholdStatusInternal :: Members '[LegalHoldStore, TeamFeatureStore, TeamStore] r => GetFeatureInternalParam -> - Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureLegalHold) + Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureLegalHold) getLegalholdStatusInternal (Left _) = pure $ Public.TeamFeatureStatusNoConfig Public.TeamFeatureDisabled getLegalholdStatusInternal (Right tid) = do @@ -440,8 +464,8 @@ setLegalholdStatusInternal :: r ) => TeamId -> - Public.TeamFeatureStatus 'Public.TeamFeatureLegalHold -> - Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureLegalHold) + Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureLegalHold -> + Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureLegalHold) setLegalholdStatusInternal tid status@(Public.tfwoStatus -> statusValue) = do do -- this extra do is to encapsulate the assertions running before the actual operation. @@ -461,29 +485,29 @@ setLegalholdStatusInternal tid status@(Public.tfwoStatus -> statusValue) = do Public.TeamFeatureDisabled -> removeSettings' @p tid Public.TeamFeatureEnabled -> do ensureNotTooLargeToActivateLegalHold tid - TeamFeatures.setFeatureStatusNoConfig @'Public.TeamFeatureLegalHold tid status + TeamFeatures.setFeatureStatusNoConfig @'Public.WithoutLockStatus @'Public.TeamFeatureLegalHold tid status getFileSharingInternal :: Members '[Input Opts, TeamFeatureStore] r => GetFeatureInternalParam -> - Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureFileSharing) + Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureFileSharing) getFileSharingInternal = - getFeatureStatusWithDefaultConfig @'Public.TeamFeatureFileSharing flagFileSharing . either (const Nothing) Just + getFeatureStatusWithDefaultConfig @'Public.WithoutLockStatus @'Public.TeamFeatureFileSharing flagFileSharing . either (const Nothing) Just getFeatureStatusWithDefaultConfig :: - forall (a :: TeamFeatureName) r. + forall (ps :: Public.IncludeLockStatus) (a :: TeamFeatureName) r. ( KnownTeamFeatureName a, HasStatusCol a, - FeatureHasNoConfig a, + FeatureHasNoConfig ps a, Members '[Input Opts, TeamFeatureStore] r ) => - Lens' FeatureFlags (Defaults (Public.TeamFeatureStatus a)) -> + Lens' FeatureFlags (Defaults (Public.TeamFeatureStatus ps a)) -> Maybe TeamId -> - Sem r (Public.TeamFeatureStatus a) + Sem r (Public.TeamFeatureStatus ps a) getFeatureStatusWithDefaultConfig lens' = maybe (Public.TeamFeatureStatusNoConfig <$> getDef) - (getFeatureStatusNoConfig @a getDef) + (getFeatureStatusNoConfig @ps @a getDef) where getDef :: Sem r Public.TeamFeatureStatusValue getDef = @@ -493,14 +517,14 @@ getFeatureStatusWithDefaultConfig lens' = setFileSharingInternal :: Members '[GundeckAccess, TeamFeatureStore, TeamStore, P.TinyLog] r => TeamId -> - Public.TeamFeatureStatus 'Public.TeamFeatureFileSharing -> - Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureFileSharing) -setFileSharingInternal = setFeatureStatusNoConfig @'Public.TeamFeatureFileSharing $ \_status _tid -> pure () + Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureFileSharing -> + Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureFileSharing) +setFileSharingInternal = setFeatureStatusNoConfig @'Public.WithoutLockStatus @'Public.TeamFeatureFileSharing $ \_status _tid -> pure () getAppLockInternal :: Members '[Input Opts, TeamFeatureStore] r => GetFeatureInternalParam -> - Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureAppLock) + Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureAppLock) getAppLockInternal mbtid = do Defaults defaultStatus <- inputs (view (optSettings . setFeatureFlags . flagAppLockDefaults)) status <- @@ -510,67 +534,104 @@ getAppLockInternal mbtid = do setAppLockInternal :: Members '[GundeckAccess, TeamFeatureStore, TeamStore, Error TeamFeatureError, P.TinyLog] r => TeamId -> - Public.TeamFeatureStatus 'Public.TeamFeatureAppLock -> - Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureAppLock) + Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureAppLock -> + Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureAppLock) setAppLockInternal tid status = do when (Public.applockInactivityTimeoutSecs (Public.tfwcConfig status) < 30) $ throw AppLockinactivityTimeoutTooLow let pushEvent = pushFeatureConfigEvent tid $ Event.Event Event.Update Public.TeamFeatureAppLock (EdFeatureApplockChanged status) - (TeamFeatures.setApplockFeatureStatus tid status) <* pushEvent + TeamFeatures.setApplockFeatureStatus tid status <* pushEvent getClassifiedDomainsInternal :: Member (Input Opts) r => GetFeatureInternalParam -> - Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureClassifiedDomains) + Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureClassifiedDomains) getClassifiedDomainsInternal _mbtid = do globalConfig <- inputs (view (optSettings . setFeatureFlags . flagClassifiedDomains)) let config = globalConfig pure $ case Public.tfwcStatus config of - Public.TeamFeatureDisabled -> - Public.TeamFeatureStatusWithConfig Public.TeamFeatureDisabled (Public.TeamFeatureClassifiedDomainsConfig []) + Public.TeamFeatureDisabled -> Public.defaultClassifiedDomains Public.TeamFeatureEnabled -> config getConferenceCallingInternal :: Members '[BrigAccess, Input Opts, TeamFeatureStore] r => GetFeatureInternalParam -> - Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureConferenceCalling) + Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureConferenceCalling) getConferenceCallingInternal (Left (Just uid)) = do getFeatureConfigViaAccount @'Public.TeamFeatureConferenceCalling uid getConferenceCallingInternal (Left Nothing) = do - getFeatureStatusWithDefaultConfig @'Public.TeamFeatureConferenceCalling flagConferenceCalling Nothing + getFeatureStatusWithDefaultConfig @'Public.WithoutLockStatus @'Public.TeamFeatureConferenceCalling flagConferenceCalling Nothing getConferenceCallingInternal (Right tid) = do - getFeatureStatusWithDefaultConfig @'Public.TeamFeatureConferenceCalling flagConferenceCalling (Just tid) + getFeatureStatusWithDefaultConfig @'Public.WithoutLockStatus @'Public.TeamFeatureConferenceCalling flagConferenceCalling (Just tid) setConferenceCallingInternal :: Members '[GundeckAccess, TeamFeatureStore, TeamStore, P.TinyLog] r => TeamId -> - Public.TeamFeatureStatus 'Public.TeamFeatureConferenceCalling -> - Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureConferenceCalling) + Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureConferenceCalling -> + Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureConferenceCalling) setConferenceCallingInternal = - setFeatureStatusNoConfig @'Public.TeamFeatureConferenceCalling $ \_status _tid -> pure () + setFeatureStatusNoConfig @'Public.WithoutLockStatus @'Public.TeamFeatureConferenceCalling $ \_status _tid -> pure () getSelfDeletingMessagesInternal :: - Member TeamFeatureStore r => + forall r. + ( Member (Input Opts) r, + Member TeamFeatureStore r + ) => GetFeatureInternalParam -> - Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureSelfDeletingMessages) + Sem r (Public.TeamFeatureStatus 'Public.WithLockStatus 'Public.TeamFeatureSelfDeletingMessages) getSelfDeletingMessagesInternal = \case - Left _ -> pure Public.defaultSelfDeletingMessagesStatus - Right tid -> - TeamFeatures.getSelfDeletingMessagesStatus tid - <&> maybe Public.defaultSelfDeletingMessagesStatus id + Left _ -> getCfgDefault + Right tid -> do + cfgDefault <- getCfgDefault + let defLockStatus = Public.tfwcapsLockStatus cfgDefault + (maybeFeatureStatus, fromMaybe defLockStatus -> lockStatus) <- TeamFeatures.getSelfDeletingMessagesStatus tid + pure $ case (lockStatus, maybeFeatureStatus) of + (Public.Unlocked, Just featureStatus) -> + Public.TeamFeatureStatusWithConfigAndLockStatus + (Public.tfwcStatus featureStatus) + (Public.tfwcConfig featureStatus) + Public.Unlocked + (Public.Unlocked, Nothing) -> cfgDefault {Public.tfwcapsLockStatus = Public.Unlocked} + (Public.Locked, _) -> cfgDefault {Public.tfwcapsLockStatus = Public.Locked} + where + getCfgDefault :: Sem r (Public.TeamFeatureStatusWithConfigAndLockStatus Public.TeamFeatureSelfDeletingMessagesConfig) + getCfgDefault = input <&> view (optSettings . setFeatureFlags . flagSelfDeletingMessages . unDefaults) setSelfDeletingMessagesInternal :: - Members '[GundeckAccess, TeamFeatureStore, TeamStore, P.TinyLog] r => + Members + '[ GundeckAccess, + TeamStore, + TeamFeatureStore, + P.TinyLog, + Error TeamFeatureError + ] + r => TeamId -> - Public.TeamFeatureStatus 'Public.TeamFeatureSelfDeletingMessages -> - Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureSelfDeletingMessages) + Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureSelfDeletingMessages -> + Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureSelfDeletingMessages) setSelfDeletingMessagesInternal tid st = do + guardLockStatus @'Public.TeamFeatureSelfDeletingMessages tid Public.Locked let pushEvent = pushFeatureConfigEvent tid $ Event.Event Event.Update Public.TeamFeatureSelfDeletingMessages (EdFeatureSelfDeletingMessagesChanged st) - (TeamFeatures.setSelfDeletingMessagesStatus tid st) <* pushEvent + TeamFeatures.setSelfDeletingMessagesStatus tid st <* pushEvent + +-- TODO(fisx): move this function to a more suitable place / module. +guardLockStatus :: + forall (a :: Public.TeamFeatureName) r. + ( MaybeHasLockStatusCol a, + Member TeamFeatureStore r, + Member (Error TeamFeatureError) r + ) => + TeamId -> + Public.LockStatusValue -> -- FUTUREWORK(fisx): move this into its own type class and infer from `a`? + Sem r () +guardLockStatus tid defLockStatus = do + (TeamFeatures.getLockStatus @a tid <&> fromMaybe defLockStatus) >>= \case + Public.Unlocked -> pure () + Public.Locked -> throw FeatureLocked pushFeatureConfigEvent :: Members '[GundeckAccess, TeamStore, P.TinyLog] r => @@ -588,7 +649,7 @@ pushFeatureConfigEvent tid event = do let recipients = membersToRecipients Nothing (memList ^. teamMembers) for_ (newPush (memList ^. teamMemberListType) Nothing (FeatureConfigEvent event) recipients) - (push1) + push1 -- | (Currently, we only have 'Public.TeamFeatureConferenceCalling' here, but we may have to -- extend this in the future.) @@ -597,5 +658,5 @@ getFeatureConfigViaAccount :: Member BrigAccess r ) => UserId -> - Sem r (Public.TeamFeatureStatus flag) + Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus flag) getFeatureConfigViaAccount = getAccountFeatureConfigClient diff --git a/services/galley/src/Galley/Cassandra.hs b/services/galley/src/Galley/Cassandra.hs index a32e4fdce1a..83a0a5abd1f 100644 --- a/services/galley/src/Galley/Cassandra.hs +++ b/services/galley/src/Galley/Cassandra.hs @@ -20,4 +20,4 @@ module Galley.Cassandra (schemaVersion) where import Imports schemaVersion :: Int32 -schemaVersion = 54 +schemaVersion = 55 diff --git a/services/galley/src/Galley/Cassandra/TeamFeatures.hs b/services/galley/src/Galley/Cassandra/TeamFeatures.hs index e723fe47689..c72d549f656 100644 --- a/services/galley/src/Galley/Cassandra/TeamFeatures.hs +++ b/services/galley/src/Galley/Cassandra/TeamFeatures.hs @@ -30,15 +30,16 @@ import Polysemy.Input import Wire.API.Team.Feature getFeatureStatusNoConfig :: - forall (a :: TeamFeatureName) m. + forall (ps :: IncludeLockStatus) (a :: TeamFeatureName) m. ( MonadClient m, - FeatureHasNoConfig a, + FeatureHasNoConfig ps a, HasStatusCol a ) => + Proxy ps -> Proxy a -> TeamId -> - m (Maybe (TeamFeatureStatus a)) -getFeatureStatusNoConfig _ tid = do + m (Maybe (TeamFeatureStatus ps a)) +getFeatureStatusNoConfig _ _ tid = do let q = query1 select (params LocalQuorum (Identity tid)) mStatusValue <- (>>= runIdentity) <$> retry x1 q pure $ TeamFeatureStatusNoConfig <$> mStatusValue @@ -47,16 +48,17 @@ getFeatureStatusNoConfig _ tid = do select = fromString $ "select " <> statusCol @a <> " from team_features where team_id = ?" setFeatureStatusNoConfig :: - forall (a :: TeamFeatureName) m. + forall (ps :: IncludeLockStatus) (a :: TeamFeatureName) m. ( MonadClient m, - FeatureHasNoConfig a, + FeatureHasNoConfig ps a, HasStatusCol a ) => + Proxy ps -> Proxy a -> TeamId -> - TeamFeatureStatus a -> - m (TeamFeatureStatus a) -setFeatureStatusNoConfig _ tid status = do + TeamFeatureStatus ps a -> + m (TeamFeatureStatus ps a) +setFeatureStatusNoConfig _ _ tid status = do let flag = tfwoStatus status retry x5 $ write insert (params LocalQuorum (tid, flag)) pure status @@ -68,7 +70,7 @@ getApplockFeatureStatus :: forall m. (MonadClient m) => TeamId -> - m (Maybe (TeamFeatureStatus 'TeamFeatureAppLock)) + m (Maybe (TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureAppLock)) getApplockFeatureStatus tid = do let q = query1 select (params LocalQuorum (Identity tid)) mTuple <- retry x1 q @@ -85,8 +87,8 @@ getApplockFeatureStatus tid = do setApplockFeatureStatus :: (MonadClient m) => TeamId -> - TeamFeatureStatus 'TeamFeatureAppLock -> - m (TeamFeatureStatus 'TeamFeatureAppLock) + TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureAppLock -> + m (TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureAppLock) setApplockFeatureStatus tid status = do let statusValue = tfwcStatus status enforce = applockEnforceAppLock . tfwcConfig $ status @@ -105,27 +107,30 @@ getSelfDeletingMessagesStatus :: forall m. (MonadClient m) => TeamId -> - m (Maybe (TeamFeatureStatus 'TeamFeatureSelfDeletingMessages)) + m (Maybe (TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureSelfDeletingMessages), Maybe LockStatusValue) getSelfDeletingMessagesStatus tid = do let q = query1 select (params LocalQuorum (Identity tid)) mTuple <- retry x1 q - pure $ - mTuple >>= \(mbStatusValue, mbTimeout) -> - TeamFeatureStatusWithConfig <$> mbStatusValue <*> (TeamFeatureSelfDeletingMessagesConfig <$> mbTimeout) + pure + ( mTuple >>= \(mbStatusValue, mbTimeout, _) -> + TeamFeatureStatusWithConfig <$> mbStatusValue <*> (TeamFeatureSelfDeletingMessagesConfig <$> mbTimeout), + mTuple >>= \(_, _, mbLockStatus) -> mbLockStatus + ) where - select :: PrepQuery R (Identity TeamId) (Maybe TeamFeatureStatusValue, Maybe Int32) + select :: PrepQuery R (Identity TeamId) (Maybe TeamFeatureStatusValue, Maybe Int32, Maybe LockStatusValue) select = fromString $ "select " <> statusCol @'TeamFeatureSelfDeletingMessages - <> ", self_deleting_messages_ttl " - <> "from team_features where team_id = ?" + <> ", self_deleting_messages_ttl, " + <> lockStatusCol @'TeamFeatureSelfDeletingMessages + <> " from team_features where team_id = ?" setSelfDeletingMessagesStatus :: (MonadClient m) => TeamId -> - TeamFeatureStatus 'TeamFeatureSelfDeletingMessages -> - m (TeamFeatureStatus 'TeamFeatureSelfDeletingMessages) + TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureSelfDeletingMessages -> + m (TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureSelfDeletingMessages) setSelfDeletingMessagesStatus tid status = do let statusValue = tfwcStatus status timeout = sdmEnforcedTimeoutSeconds . tfwcConfig $ status @@ -140,13 +145,55 @@ setSelfDeletingMessagesStatus tid status = do <> ", self_deleting_messages_ttl) " <> "values (?, ?, ?)" +setLockStatus :: + forall (a :: TeamFeatureName) m. + ( MonadClient m, + HasLockStatusCol a + ) => + Proxy a -> + TeamId -> + LockStatus -> + m LockStatus +setLockStatus _ tid (LockStatus lockStatus) = do + retry x5 $ write insert (params LocalQuorum (tid, lockStatus)) + pure (LockStatus lockStatus) + where + insert :: PrepQuery W (TeamId, LockStatusValue) () + insert = + fromString $ + "insert into team_features (team_id, " <> lockStatusCol @a <> ") values (?, ?)" + +getLockStatus :: + forall (a :: TeamFeatureName) m. + ( MonadClient m, + MaybeHasLockStatusCol a + ) => + Proxy a -> + TeamId -> + m (Maybe LockStatusValue) +getLockStatus _ tid = + case maybeLockStatusCol @a of + Nothing -> pure Nothing + Just lockStatusColName -> do + let q = query1 select (params LocalQuorum (Identity tid)) + (>>= runIdentity) <$> retry x1 q + where + select :: PrepQuery R (Identity TeamId) (Identity (Maybe LockStatusValue)) + select = + fromString $ + "select " + <> lockStatusColName + <> " from team_features where team_id = ?" + interpretTeamFeatureStoreToCassandra :: Members '[Embed IO, Input ClientState] r => Sem (TeamFeatureStore ': r) a -> Sem r a interpretTeamFeatureStoreToCassandra = interpret $ \case - GetFeatureStatusNoConfig' p tid -> embedClient $ getFeatureStatusNoConfig p tid - SetFeatureStatusNoConfig' p tid value -> embedClient $ setFeatureStatusNoConfig p tid value + GetFeatureStatusNoConfig' ps tfn tid -> embedClient $ getFeatureStatusNoConfig ps tfn tid + SetFeatureStatusNoConfig' ps tfn tid value -> embedClient $ setFeatureStatusNoConfig ps tfn tid value + SetLockStatus' p tid value -> embedClient $ setLockStatus p tid value + GetLockStatus' p tid -> embedClient $ getLockStatus p tid GetApplockFeatureStatus tid -> embedClient $ getApplockFeatureStatus tid SetApplockFeatureStatus tid value -> embedClient $ setApplockFeatureStatus tid value GetSelfDeletingMessagesStatus tid -> embedClient $ getSelfDeletingMessagesStatus tid diff --git a/services/galley/src/Galley/Data/TeamFeatures.hs b/services/galley/src/Galley/Data/TeamFeatures.hs index e7ab337d0f5..65a6cc6648b 100644 --- a/services/galley/src/Galley/Data/TeamFeatures.hs +++ b/services/galley/src/Galley/Data/TeamFeatures.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.Data.TeamFeatures (HasStatusCol (..)) where +module Galley.Data.TeamFeatures (HasStatusCol (..), HasLockStatusCol (..), MaybeHasLockStatusCol (..)) where import Imports import Wire.API.Team.Feature @@ -48,3 +48,33 @@ instance HasStatusCol 'TeamFeatureFileSharing where statusCol = "file_sharing" instance HasStatusCol 'TeamFeatureConferenceCalling where statusCol = "conference_calling" instance HasStatusCol 'TeamFeatureSelfDeletingMessages where statusCol = "self_deleting_messages_status" + +---------------------------------------------------------------------- +class HasLockStatusCol (a :: TeamFeatureName) where + lockStatusCol :: String + +class MaybeHasLockStatusCol (a :: TeamFeatureName) where + maybeLockStatusCol :: Maybe String + +instance {-# OVERLAPPABLE #-} HasLockStatusCol a => MaybeHasLockStatusCol a where + maybeLockStatusCol = Just (lockStatusCol @a) + +---------------------------------------------------------------------- +instance HasLockStatusCol 'TeamFeatureSelfDeletingMessages where + lockStatusCol = "self_deleting_messages_lock_status" + +instance MaybeHasLockStatusCol 'TeamFeatureLegalHold where maybeLockStatusCol = Nothing + +instance MaybeHasLockStatusCol 'TeamFeatureSSO where maybeLockStatusCol = Nothing + +instance MaybeHasLockStatusCol 'TeamFeatureSearchVisibility where maybeLockStatusCol = Nothing + +instance MaybeHasLockStatusCol 'TeamFeatureValidateSAMLEmails where maybeLockStatusCol = Nothing + +instance MaybeHasLockStatusCol 'TeamFeatureDigitalSignatures where maybeLockStatusCol = Nothing + +instance MaybeHasLockStatusCol 'TeamFeatureAppLock where maybeLockStatusCol = Nothing + +instance MaybeHasLockStatusCol 'TeamFeatureFileSharing where maybeLockStatusCol = Nothing + +instance MaybeHasLockStatusCol 'TeamFeatureConferenceCalling where maybeLockStatusCol = Nothing diff --git a/services/galley/src/Galley/Effects/TeamFeatureStore.hs b/services/galley/src/Galley/Effects/TeamFeatureStore.hs index d2910980f20..8e5673ba242 100644 --- a/services/galley/src/Galley/Effects/TeamFeatureStore.hs +++ b/services/galley/src/Galley/Effects/TeamFeatureStore.hs @@ -23,6 +23,8 @@ module Galley.Effects.TeamFeatureStore setApplockFeatureStatus, getSelfDeletingMessagesStatus, setSelfDeletingMessagesStatus, + setLockStatus, + getLockStatus, ) where @@ -36,51 +38,83 @@ import Wire.API.Team.Feature data TeamFeatureStore m a where -- the proxy argument makes sure that makeSem below generates type-inference-friendly code GetFeatureStatusNoConfig' :: - forall (a :: TeamFeatureName) m. - ( FeatureHasNoConfig a, + forall (ps :: IncludeLockStatus) (a :: TeamFeatureName) m. + ( FeatureHasNoConfig ps a, HasStatusCol a ) => + Proxy ps -> Proxy a -> TeamId -> - TeamFeatureStore m (Maybe (TeamFeatureStatus a)) + TeamFeatureStore m (Maybe (TeamFeatureStatus ps a)) -- the proxy argument makes sure that makeSem below generates type-inference-friendly code SetFeatureStatusNoConfig' :: - forall (a :: TeamFeatureName) m. - ( FeatureHasNoConfig a, + forall (ps :: IncludeLockStatus) (a :: TeamFeatureName) m. + ( FeatureHasNoConfig ps a, HasStatusCol a ) => + Proxy ps -> Proxy a -> TeamId -> - TeamFeatureStatus a -> - TeamFeatureStore m (TeamFeatureStatus a) + TeamFeatureStatus ps a -> + TeamFeatureStore m (TeamFeatureStatus ps a) GetApplockFeatureStatus :: TeamId -> - TeamFeatureStore m (Maybe (TeamFeatureStatus 'TeamFeatureAppLock)) + TeamFeatureStore m (Maybe (TeamFeatureStatus ps 'TeamFeatureAppLock)) SetApplockFeatureStatus :: TeamId -> - TeamFeatureStatus 'TeamFeatureAppLock -> - TeamFeatureStore m (TeamFeatureStatus 'TeamFeatureAppLock) + TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureAppLock -> + TeamFeatureStore m (TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureAppLock) GetSelfDeletingMessagesStatus :: TeamId -> - TeamFeatureStore m (Maybe (TeamFeatureStatus 'TeamFeatureSelfDeletingMessages)) + TeamFeatureStore m (Maybe (TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureSelfDeletingMessages), Maybe LockStatusValue) SetSelfDeletingMessagesStatus :: TeamId -> - TeamFeatureStatus 'TeamFeatureSelfDeletingMessages -> - TeamFeatureStore m (TeamFeatureStatus 'TeamFeatureSelfDeletingMessages) + TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureSelfDeletingMessages -> + TeamFeatureStore m (TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureSelfDeletingMessages) + SetLockStatus' :: + forall (a :: TeamFeatureName) m. + ( HasLockStatusCol a + ) => + Proxy a -> + TeamId -> + LockStatus -> + TeamFeatureStore m LockStatus + GetLockStatus' :: + forall (a :: TeamFeatureName) m. + ( MaybeHasLockStatusCol a + ) => + Proxy a -> + TeamId -> + TeamFeatureStore m (Maybe LockStatusValue) makeSem ''TeamFeatureStore getFeatureStatusNoConfig :: - forall (a :: TeamFeatureName) r. - (Member TeamFeatureStore r, FeatureHasNoConfig a, HasStatusCol a) => + forall (ps :: IncludeLockStatus) (a :: TeamFeatureName) r. + (Member TeamFeatureStore r, FeatureHasNoConfig ps a, HasStatusCol a) => TeamId -> - Sem r (Maybe (TeamFeatureStatus a)) -getFeatureStatusNoConfig = getFeatureStatusNoConfig' (Proxy @a) + Sem r (Maybe (TeamFeatureStatus ps a)) +getFeatureStatusNoConfig = getFeatureStatusNoConfig' (Proxy @ps) (Proxy @a) setFeatureStatusNoConfig :: + forall (ps :: IncludeLockStatus) (a :: TeamFeatureName) r. + (Member TeamFeatureStore r, FeatureHasNoConfig ps a, HasStatusCol a) => + TeamId -> + TeamFeatureStatus ps a -> + Sem r (TeamFeatureStatus ps a) +setFeatureStatusNoConfig = setFeatureStatusNoConfig' (Proxy @ps) (Proxy @a) + +setLockStatus :: + forall (a :: TeamFeatureName) r. + (Member TeamFeatureStore r, HasLockStatusCol a) => + TeamId -> + LockStatus -> + Sem r LockStatus +setLockStatus = setLockStatus' (Proxy @a) + +getLockStatus :: forall (a :: TeamFeatureName) r. - (Member TeamFeatureStore r, FeatureHasNoConfig a, HasStatusCol a) => + (Member TeamFeatureStore r, MaybeHasLockStatusCol a) => TeamId -> - TeamFeatureStatus a -> - Sem r (TeamFeatureStatus a) -setFeatureStatusNoConfig = setFeatureStatusNoConfig' (Proxy @a) + Sem r (Maybe LockStatusValue) +getLockStatus = getLockStatus' (Proxy @a) diff --git a/services/galley/test/integration/API/Teams.hs b/services/galley/test/integration/API/Teams.hs index 43985abb00b..a1edf78225a 100644 --- a/services/galley/test/integration/API/Teams.hs +++ b/services/galley/test/integration/API/Teams.hs @@ -355,7 +355,7 @@ testEnableSSOPerTeam = do assertQueue "create team" tActivate let check :: HasCallStack => String -> Public.TeamFeatureStatusValue -> TestM () check msg enabledness = do - status :: Public.TeamFeatureStatus 'Public.TeamFeatureSSO <- responseJsonUnsafe <$> (getSSOEnabledInternal tid (getSSOEnabledInternal tid TestM () @@ -382,10 +382,10 @@ testEnableSSOPerTeam = do testEnableTeamSearchVisibilityPerTeam :: TestM () testEnableTeamSearchVisibilityPerTeam = do g <- view tsGalley - (tid, owner, (member : _)) <- Util.createBindingTeamWithMembers 2 + (tid, owner, member : _) <- Util.createBindingTeamWithMembers 2 let check :: (HasCallStack, MonadCatch m, MonadIO m, Monad m, MonadHttp m) => String -> Public.TeamFeatureStatusValue -> m () check msg enabledness = do - status :: Public.TeamFeatureStatus 'Public.TeamFeatureSearchVisibility <- responseJsonUnsafe <$> (Util.getTeamSearchVisibilityAvailableInternal g tid (Util.getTeamSearchVisibilityAvailableInternal g tid return (x, xs) (201, 200, _, _) -> createAndConnectUserWhileLimitNotReached alice (remaining -1) ((uid, cid) : acc) pk (403, 403, _, []) -> error "Need to connect with at least 1 user" - (403, 403, _, (x : xs)) -> return (x, xs) + (403, 403, _, x : xs) -> return (x, xs) (xxx, yyy, _, _) -> error ("Unexpected while connecting users: " ++ show xxx ++ " and " ++ show yyy) newTeamMember' :: Permissions -> UserId -> TeamMember @@ -1892,7 +1892,7 @@ getSSOEnabledInternal :: HasCallStack => TeamId -> TestM ResponseLBS getSSOEnabledInternal = Util.getTeamFeatureFlagInternal Public.TeamFeatureSSO putSSOEnabledInternal :: HasCallStack => TeamId -> Public.TeamFeatureStatusValue -> TestM () -putSSOEnabledInternal tid statusValue = Util.putTeamFeatureFlagInternal @'Public.TeamFeatureSSO expect2xx tid (Public.TeamFeatureStatusNoConfig statusValue) +putSSOEnabledInternal tid statusValue = void $ Util.putTeamFeatureFlagInternal @'Public.WithoutLockStatus @'Public.TeamFeatureSSO expect2xx tid (Public.TeamFeatureStatusNoConfig statusValue) getSearchVisibility :: HasCallStack => (Request -> Request) -> UserId -> TeamId -> (MonadIO m, MonadHttp m) => m ResponseLBS getSearchVisibility g uid tid = do diff --git a/services/galley/test/integration/API/Teams/Feature.hs b/services/galley/test/integration/API/Teams/Feature.hs index 76c5f7b408d..ba2a64110d5 100644 --- a/services/galley/test/integration/API/Teams/Feature.hs +++ b/services/galley/test/integration/API/Teams/Feature.hs @@ -22,7 +22,7 @@ import qualified API.Util as Util import qualified API.Util.TeamFeature as Util import Bilge import Bilge.Assert -import Control.Lens (over, view) +import Control.Lens (over, to, view) import Control.Monad.Catch (MonadCatch) import Data.Aeson (FromJSON, ToJSON, object, (.=)) import qualified Data.Aeson as Aeson @@ -60,15 +60,15 @@ tests s = [ test s "SSO" testSSO, test s "LegalHold" testLegalHold, test s "SearchVisibility" testSearchVisibility, - test s "DigitalSignatures" $ testSimpleFlag @'Public.TeamFeatureDigitalSignatures Public.TeamFeatureDisabled, - test s "ValidateSAMLEmails" $ testSimpleFlag @'Public.TeamFeatureValidateSAMLEmails Public.TeamFeatureDisabled, - test s "FileSharing" $ testSimpleFlag @'Public.TeamFeatureFileSharing Public.TeamFeatureEnabled, + test s "DigitalSignatures" $ testSimpleFlag @'Public.WithoutLockStatus @'Public.TeamFeatureDigitalSignatures Public.TeamFeatureDisabled, + test s "ValidateSAMLEmails" $ testSimpleFlag @'Public.WithoutLockStatus @'Public.TeamFeatureValidateSAMLEmails Public.TeamFeatureDisabled, + test s "FileSharing" $ testSimpleFlag @'Public.WithoutLockStatus @'Public.TeamFeatureFileSharing Public.TeamFeatureEnabled, test s "Classified Domains (enabled)" testClassifiedDomainsEnabled, test s "Classified Domains (disabled)" testClassifiedDomainsDisabled, test s "All features" testAllFeatures, test s "Feature Configs / Team Features Consistency" testFeatureConfigConsistency, - test s "ConferenceCalling" $ testSimpleFlag @'Public.TeamFeatureConferenceCalling Public.TeamFeatureEnabled, - test s "SelfDeletingMessages" $ testSelfDeletingMessages + test s "ConferenceCalling" $ testSimpleFlag @'Public.WithoutLockStatus @'Public.TeamFeatureConferenceCalling Public.TeamFeatureEnabled, + test s "SelfDeletingMessages" testSelfDeletingMessages ] testSSO :: TestM () @@ -81,13 +81,13 @@ testSSO = do Util.addTeamMember owner tid member (rolePermissions RoleMember) Nothing let getSSO :: HasCallStack => Public.TeamFeatureStatusValue -> TestM () - getSSO = assertFlagNoConfig @'Public.TeamFeatureSSO $ Util.getTeamFeatureFlag Public.TeamFeatureSSO member tid + getSSO = assertFlagNoConfig @'Public.WithoutLockStatus @'Public.TeamFeatureSSO $ Util.getTeamFeatureFlag Public.TeamFeatureSSO member tid getSSOFeatureConfig :: HasCallStack => Public.TeamFeatureStatusValue -> TestM () - getSSOFeatureConfig = assertFlagNoConfig @'Public.TeamFeatureSSO $ Util.getFeatureConfig Public.TeamFeatureSSO member + getSSOFeatureConfig = assertFlagNoConfig @'Public.WithoutLockStatus @'Public.TeamFeatureSSO $ Util.getFeatureConfig Public.TeamFeatureSSO member getSSOInternal :: HasCallStack => Public.TeamFeatureStatusValue -> TestM () - getSSOInternal = assertFlagNoConfig @'Public.TeamFeatureSSO $ Util.getTeamFeatureFlagInternal Public.TeamFeatureSSO tid + getSSOInternal = assertFlagNoConfig @'Public.WithoutLockStatus @'Public.TeamFeatureSSO $ Util.getTeamFeatureFlagInternal Public.TeamFeatureSSO tid setSSOInternal :: HasCallStack => Public.TeamFeatureStatusValue -> TestM () - setSSOInternal = Util.putTeamFeatureFlagInternal @'Public.TeamFeatureSSO expect2xx tid . Public.TeamFeatureStatusNoConfig + setSSOInternal = void . Util.putTeamFeatureFlagInternal @'Public.WithoutLockStatus @'Public.TeamFeatureSSO expect2xx tid . Public.TeamFeatureStatusNoConfig assertFlagForbidden $ Util.getTeamFeatureFlag Public.TeamFeatureSSO nonMember tid @@ -121,13 +121,13 @@ testLegalHold = do Util.addTeamMember owner tid member (rolePermissions RoleMember) Nothing let getLegalHold :: HasCallStack => Public.TeamFeatureStatusValue -> TestM () - getLegalHold = assertFlagNoConfig @'Public.TeamFeatureLegalHold $ Util.getTeamFeatureFlag Public.TeamFeatureLegalHold member tid + getLegalHold = assertFlagNoConfig @'Public.WithoutLockStatus @'Public.TeamFeatureLegalHold $ Util.getTeamFeatureFlag Public.TeamFeatureLegalHold member tid getLegalHoldInternal :: HasCallStack => Public.TeamFeatureStatusValue -> TestM () - getLegalHoldInternal = assertFlagNoConfig @'Public.TeamFeatureLegalHold $ Util.getTeamFeatureFlagInternal Public.TeamFeatureLegalHold tid - getLegalHoldFeatureConfig = assertFlagNoConfig @'Public.TeamFeatureLegalHold $ Util.getFeatureConfig Public.TeamFeatureLegalHold member + getLegalHoldInternal = assertFlagNoConfig @'Public.WithoutLockStatus @'Public.TeamFeatureLegalHold $ Util.getTeamFeatureFlagInternal Public.TeamFeatureLegalHold tid + getLegalHoldFeatureConfig = assertFlagNoConfig @'Public.WithoutLockStatus @'Public.TeamFeatureLegalHold $ Util.getFeatureConfig Public.TeamFeatureLegalHold member setLegalHoldInternal :: HasCallStack => Public.TeamFeatureStatusValue -> TestM () - setLegalHoldInternal = Util.putTeamFeatureFlagInternal @'Public.TeamFeatureLegalHold expect2xx tid . Public.TeamFeatureStatusNoConfig + setLegalHoldInternal = void . Util.putTeamFeatureFlagInternal @'Public.WithoutLockStatus @'Public.TeamFeatureLegalHold expect2xx tid . Public.TeamFeatureStatusNoConfig getLegalHold Public.TeamFeatureDisabled getLegalHoldInternal Public.TeamFeatureDisabled @@ -249,7 +249,7 @@ getClassifiedDomains :: (HasCallStack, HasGalley m, MonadIO m, MonadHttp m, MonadCatch m) => UserId -> TeamId -> - Public.TeamFeatureStatus 'Public.TeamFeatureClassifiedDomains -> + Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureClassifiedDomains -> m () getClassifiedDomains member tid = assertFlagWithConfig @Public.TeamFeatureClassifiedDomainsConfig $ @@ -258,7 +258,7 @@ getClassifiedDomains member tid = getClassifiedDomainsInternal :: (HasCallStack, HasGalley m, MonadIO m, MonadHttp m, MonadCatch m) => TeamId -> - Public.TeamFeatureStatus 'Public.TeamFeatureClassifiedDomains -> + Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureClassifiedDomains -> m () getClassifiedDomainsInternal tid = assertFlagWithConfig @Public.TeamFeatureClassifiedDomainsConfig $ @@ -276,7 +276,7 @@ testClassifiedDomainsEnabled = do let getClassifiedDomainsFeatureConfig :: (HasCallStack, HasGalley m, MonadIO m, MonadHttp m, MonadCatch m) => UserId -> - Public.TeamFeatureStatus 'Public.TeamFeatureClassifiedDomains -> + Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureClassifiedDomains -> m () getClassifiedDomainsFeatureConfig uid = do assertFlagWithConfig @Public.TeamFeatureClassifiedDomainsConfig $ @@ -298,7 +298,7 @@ testClassifiedDomainsDisabled = do let getClassifiedDomainsFeatureConfig :: (HasCallStack, HasGalley m, MonadIO m, MonadHttp m, MonadCatch m) => UserId -> - Public.TeamFeatureStatus 'Public.TeamFeatureClassifiedDomains -> + Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureClassifiedDomains -> m () getClassifiedDomainsFeatureConfig uid = do assertFlagWithConfig @Public.TeamFeatureClassifiedDomainsConfig $ @@ -316,13 +316,13 @@ testClassifiedDomainsDisabled = do getClassifiedDomainsFeatureConfig member expected testSimpleFlag :: - forall (a :: Public.TeamFeatureName). + forall (ps :: Public.IncludeLockStatus) (a :: Public.TeamFeatureName). ( HasCallStack, Typeable a, - Public.FeatureHasNoConfig a, + Public.FeatureHasNoConfig ps a, Public.KnownTeamFeatureName a, - FromJSON (Public.TeamFeatureStatus a), - ToJSON (Public.TeamFeatureStatus a) + FromJSON (Public.TeamFeatureStatus 'Public.WithoutLockStatus a), + ToJSON (Public.TeamFeatureStatus ps a) ) => Public.TeamFeatureStatusValue -> TestM () @@ -337,19 +337,19 @@ testSimpleFlag defaultValue = do let getFlag :: HasCallStack => Public.TeamFeatureStatusValue -> TestM () getFlag expected = - flip (assertFlagNoConfig @a) expected $ Util.getTeamFeatureFlag feature member tid + flip (assertFlagNoConfig @ps @a) expected $ Util.getTeamFeatureFlag feature member tid getFeatureConfig :: HasCallStack => Public.TeamFeatureStatusValue -> TestM () getFeatureConfig expected = - flip (assertFlagNoConfig @a) expected $ Util.getFeatureConfig feature member + flip (assertFlagNoConfig @ps @a) expected $ Util.getFeatureConfig feature member getFlagInternal :: HasCallStack => Public.TeamFeatureStatusValue -> TestM () getFlagInternal expected = - flip (assertFlagNoConfig @a) expected $ Util.getTeamFeatureFlagInternal feature tid + flip (assertFlagNoConfig @ps @a) expected $ Util.getTeamFeatureFlagInternal feature tid setFlagInternal :: Public.TeamFeatureStatusValue -> TestM () setFlagInternal statusValue = - Util.putTeamFeatureFlagInternal @a expect2xx tid (Public.TeamFeatureStatusNoConfig statusValue) + void $ Util.putTeamFeatureFlagInternal @ps @a expect2xx tid (Public.TeamFeatureStatusNoConfig statusValue) assertFlagForbidden $ Util.getTeamFeatureFlag feature nonMember tid @@ -380,32 +380,50 @@ testSimpleFlag defaultValue = do testSelfDeletingMessages :: TestM () testSelfDeletingMessages = do + defLockStatus :: Public.LockStatusValue <- + view + ( tsGConf + . optSettings + . setFeatureFlags + . flagSelfDeletingMessages + . unDefaults + . to Public.tfwcapsLockStatus + ) + -- personal users - let setting :: TeamFeatureStatusValue -> Int32 -> Public.TeamFeatureStatus 'Public.TeamFeatureSelfDeletingMessages - setting stat tout = + let settingWithoutLockStatus :: TeamFeatureStatusValue -> Int32 -> Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureSelfDeletingMessages + settingWithoutLockStatus stat tout = Public.TeamFeatureStatusWithConfig @Public.TeamFeatureSelfDeletingMessagesConfig stat (Public.TeamFeatureSelfDeletingMessagesConfig tout) + settingWithLockStatus :: TeamFeatureStatusValue -> Int32 -> Public.LockStatusValue -> Public.TeamFeatureStatus 'Public.WithLockStatus 'Public.TeamFeatureSelfDeletingMessages + settingWithLockStatus stat tout lockStatus = + Public.TeamFeatureStatusWithConfigAndLockStatus @Public.TeamFeatureSelfDeletingMessagesConfig + stat + (Public.TeamFeatureSelfDeletingMessagesConfig tout) + lockStatus personalUser <- Util.randomUser Util.getFeatureConfig Public.TeamFeatureSelfDeletingMessages personalUser - !!! responseJsonEither === const (Right $ setting TeamFeatureEnabled 0) + !!! responseJsonEither === const (Right $ settingWithLockStatus TeamFeatureEnabled 0 defLockStatus) -- team users galley <- view tsGalley (owner, tid, []) <- Util.createBindingTeamWithNMembers 0 - let checkSet :: TeamFeatureStatusValue -> Int32 -> TestM () - checkSet stat tout = do - Util.putTeamFeatureFlagInternal @'Public.TeamFeatureSelfDeletingMessages - galley - tid - (setting stat tout) + let checkSet :: TeamFeatureStatusValue -> Int32 -> Int -> TestM () + checkSet stat tout expectedStatusCode = + do + Util.putTeamFeatureFlagInternal @'Public.WithoutLockStatus @'Public.TeamFeatureSelfDeletingMessages + galley + tid + (settingWithoutLockStatus stat tout) + !!! statusCode === const expectedStatusCode -- internal, public (/team/:tid/features), and team-agnostic (/feature-configs). - checkGet :: HasCallStack => TeamFeatureStatusValue -> Int32 -> TestM () - checkGet stat tout = do - let expected = setting stat tout + checkGet :: HasCallStack => TeamFeatureStatusValue -> Int32 -> Public.LockStatusValue -> TestM () + checkGet stat tout lockStatus = do + let expected = settingWithLockStatus stat tout lockStatus forM_ [ Util.getTeamFeatureFlagInternal Public.TeamFeatureSelfDeletingMessages tid, Util.getTeamFeatureFlagWithGalley Public.TeamFeatureSelfDeletingMessages galley owner tid, @@ -413,30 +431,66 @@ testSelfDeletingMessages = do ] (!!! responseJsonEither === const (Right expected)) - checkGet TeamFeatureEnabled 0 - checkSet TeamFeatureDisabled 0 - checkGet TeamFeatureDisabled 0 - checkSet TeamFeatureEnabled 30 - checkGet TeamFeatureEnabled 30 + checkSetLockStatus :: HasCallStack => Public.LockStatusValue -> TestM () + checkSetLockStatus status = + do + Util.setLockStatusInternal @'Public.TeamFeatureSelfDeletingMessages galley tid status + !!! statusCode === const 200 + + -- test that the default lock status comes from `galley.yaml`. + -- use this to change `galley.integration.yaml` locally and manually test that conf file + -- parsing works as expected. + checkGet TeamFeatureEnabled 0 defLockStatus + + -- now don't worry about what's in the config, write something to cassandra, and test with that. + checkSetLockStatus Public.Locked + checkGet TeamFeatureEnabled 0 Public.Locked + checkSet TeamFeatureDisabled 0 409 + checkGet TeamFeatureEnabled 0 Public.Locked + checkSet TeamFeatureEnabled 30 409 + checkGet TeamFeatureEnabled 0 Public.Locked + checkSetLockStatus Public.Unlocked + checkGet TeamFeatureEnabled 0 Public.Unlocked + checkSet TeamFeatureDisabled 0 200 + checkGet TeamFeatureDisabled 0 Public.Unlocked + checkSet TeamFeatureEnabled 30 200 + checkGet TeamFeatureEnabled 30 Public.Unlocked + checkSet TeamFeatureDisabled 30 200 + checkGet TeamFeatureDisabled 30 Public.Unlocked + checkSetLockStatus Public.Locked + checkGet TeamFeatureEnabled 0 Public.Locked + checkSet TeamFeatureEnabled 50 409 + checkSetLockStatus Public.Unlocked + checkGet TeamFeatureDisabled 30 Public.Unlocked -- | Call 'GET /teams/:tid/features' and 'GET /feature-configs', and check if all -- features are there. testAllFeatures :: TestM () testAllFeatures = do + defLockStatus :: Public.LockStatusValue <- + view + ( tsGConf + . optSettings + . setFeatureFlags + . flagSelfDeletingMessages + . unDefaults + . to Public.tfwcapsLockStatus + ) + (_owner, tid, member : _) <- Util.createBindingTeamWithNMembers 1 Util.getAllTeamFeatures member tid !!! do statusCode === const 200 - responseJsonMaybe === const (Just (expected TeamFeatureEnabled {- determined by default in galley -})) + responseJsonMaybe === const (Just (expected TeamFeatureEnabled defLockStatus {- determined by default in galley -})) Util.getAllTeamFeaturesPersonal member !!! do statusCode === const 200 - responseJsonMaybe === const (Just (expected TeamFeatureEnabled {- determined by default in galley -})) + responseJsonMaybe === const (Just (expected TeamFeatureEnabled defLockStatus {- determined by default in galley -})) randomPersonalUser <- Util.randomUser Util.getAllTeamFeaturesPersonal randomPersonalUser !!! do statusCode === const 200 - responseJsonMaybe === const (Just (expected TeamFeatureEnabled {- determined by 'getAfcConferenceCallingDefNew' in brig -})) + responseJsonMaybe === const (Just (expected TeamFeatureEnabled defLockStatus {- determined by 'getAfcConferenceCallingDefNew' in brig -})) where - expected confCalling = + expected confCalling lockState = object [ toS TeamFeatureLegalHold .= Public.TeamFeatureStatusNoConfig TeamFeatureDisabled, toS TeamFeatureSSO .= Public.TeamFeatureStatusNoConfig TeamFeatureDisabled, @@ -455,10 +509,10 @@ testAllFeatures = do toS TeamFeatureConferenceCalling .= Public.TeamFeatureStatusNoConfig confCalling, toS TeamFeatureSelfDeletingMessages - .= ( Public.TeamFeatureStatusWithConfig @Public.TeamFeatureSelfDeletingMessagesConfig - TeamFeatureEnabled - (Public.TeamFeatureSelfDeletingMessagesConfig 0) - ) + .= Public.TeamFeatureStatusWithConfigAndLockStatus @Public.TeamFeatureSelfDeletingMessagesConfig + TeamFeatureEnabled + (Public.TeamFeatureSelfDeletingMessagesConfig 0) + lockState ] toS :: TeamFeatureName -> Text toS = TE.decodeUtf8 . toByteString' @@ -478,8 +532,6 @@ testFeatureConfigConsistency = do unless (allTeamFeaturesRes `Set.isSubsetOf` allFeaturesRes) $ liftIO $ expectationFailure (show allTeamFeaturesRes <> " is not a subset of " <> show allFeaturesRes) - - pure () where parseObjectKeys :: ResponseLBS -> TestM (Set.Set Text) parseObjectKeys res = do @@ -500,11 +552,11 @@ assertFlagForbidden res = do fmap label . responseJsonMaybe === const (Just "no-team-member") assertFlagNoConfig :: - forall (a :: Public.TeamFeatureName). + forall (ps :: Public.IncludeLockStatus) (a :: Public.TeamFeatureName). ( HasCallStack, Typeable a, - Public.FeatureHasNoConfig a, - FromJSON (Public.TeamFeatureStatus a), + Public.FeatureHasNoConfig ps a, + FromJSON (Public.TeamFeatureStatus 'Public.WithoutLockStatus a), Public.KnownTeamFeatureName a ) => TestM ResponseLBS -> @@ -514,7 +566,7 @@ assertFlagNoConfig res expected = do res !!! do statusCode === const 200 ( fmap Public.tfwoStatus - . responseJsonEither @(Public.TeamFeatureStatus a) + . responseJsonEither @(Public.TeamFeatureStatus ps a) ) === const (Right expected) diff --git a/services/galley/test/integration/API/Teams/LegalHold.hs b/services/galley/test/integration/API/Teams/LegalHold.hs index 7ccefd4ea6a..d44974b5f73 100644 --- a/services/galley/test/integration/API/Teams/LegalHold.hs +++ b/services/galley/test/integration/API/Teams/LegalHold.hs @@ -566,14 +566,14 @@ testEnablePerTeam = withTeam $ \owner tid -> do addTeamMemberInternal tid member (rolePermissions RoleMember) Nothing ensureQueueEmpty do - status :: Public.TeamFeatureStatus 'Public.TeamFeatureLegalHold <- responseJsonUnsafe <$> (getEnabled tid (getEnabled tid (getEnabled tid (getEnabled tid do @@ -585,7 +585,7 @@ testEnablePerTeam = withTeam $ \owner tid -> do liftIO $ assertEqual "User legal hold status should be enabled" UserLegalHoldEnabled status do putEnabled' id tid Public.TeamFeatureDisabled !!! testResponse 403 (Just "legalhold-whitelisted-only") - status :: Public.TeamFeatureStatus 'Public.TeamFeatureLegalHold <- responseJsonUnsafe <$> (getEnabled tid (getEnabled tid (getEnabled tid (getEnabled tid (getEnabled tid (getEnabled tid do @@ -554,7 +554,7 @@ testEnablePerTeam = do liftIO $ assertEqual "User legal hold status should be enabled" UserLegalHoldEnabled status do putEnabled tid Public.TeamFeatureDisabled -- disable again - status :: Public.TeamFeatureStatus 'Public.TeamFeatureLegalHold <- responseJsonUnsafe <$> (getEnabled tid (getEnabled tid (getEnabled tid (getEnabled tid (getEnabled tid (getEnabled tid (MonadIO m, MonadHttp m) => m () putTeamSearchVisibilityAvailableInternal g tid statusValue = - putTeamFeatureFlagInternalWithGalleyAndMod - @'Public.TeamFeatureSearchVisibility - g - expect2xx - tid - (Public.TeamFeatureStatusNoConfig statusValue) + void $ + putTeamFeatureFlagInternalWithGalleyAndMod + @'Public.WithoutLockStatus + @'Public.TeamFeatureSearchVisibility + g + expect2xx + tid + (Public.TeamFeatureStatusNoConfig statusValue) putLegalHoldEnabledInternal' :: HasCallStack => @@ -65,7 +67,7 @@ putLegalHoldEnabledInternal' :: Public.TeamFeatureStatusValue -> TestM () putLegalHoldEnabledInternal' g tid statusValue = - putTeamFeatureFlagInternal @'Public.TeamFeatureLegalHold g tid (Public.TeamFeatureStatusNoConfig statusValue) + void $ putTeamFeatureFlagInternal @'Public.WithoutLockStatus @'Public.TeamFeatureLegalHold g tid (Public.TeamFeatureStatusNoConfig statusValue) -------------------------------------------------------------------------------- @@ -149,35 +151,52 @@ getAllFeatureConfigsWithGalley galley uid = do . zUser uid putTeamFeatureFlagInternal :: - forall (a :: Public.TeamFeatureName). + forall (ps :: Public.IncludeLockStatus) (a :: Public.TeamFeatureName). ( HasCallStack, Public.KnownTeamFeatureName a, - ToJSON (Public.TeamFeatureStatus a) + ToJSON (Public.TeamFeatureStatus ps a) ) => (Request -> Request) -> TeamId -> - (Public.TeamFeatureStatus a) -> - TestM () + Public.TeamFeatureStatus ps a -> + TestM ResponseLBS putTeamFeatureFlagInternal reqmod tid status = do g <- view tsGalley - putTeamFeatureFlagInternalWithGalleyAndMod @a g reqmod tid status + putTeamFeatureFlagInternalWithGalleyAndMod @ps @a g reqmod tid status putTeamFeatureFlagInternalWithGalleyAndMod :: - forall (a :: Public.TeamFeatureName) m. + forall (ps :: Public.IncludeLockStatus) (a :: Public.TeamFeatureName) m. ( MonadIO m, MonadHttp m, HasCallStack, Public.KnownTeamFeatureName a, - ToJSON (Public.TeamFeatureStatus a) + ToJSON (Public.TeamFeatureStatus ps a) ) => (Request -> Request) -> (Request -> Request) -> TeamId -> - (Public.TeamFeatureStatus a) -> - m () + Public.TeamFeatureStatus ps a -> + m ResponseLBS putTeamFeatureFlagInternalWithGalleyAndMod galley reqmod tid status = - void . put $ + put $ galley . paths ["i", "teams", toByteString' tid, "features", toByteString' (Public.knownTeamFeatureName @a)] . json status . reqmod + +setLockStatusInternal :: + forall (a :: Public.TeamFeatureName). + ( HasCallStack, + Public.KnownTeamFeatureName a, + ToJSON Public.LockStatusValue + ) => + (Request -> Request) -> + TeamId -> + Public.LockStatusValue -> + TestM ResponseLBS +setLockStatusInternal reqmod tid lockStatus = do + galley <- view tsGalley + put $ + galley + . paths ["i", "teams", toByteString' tid, "features", toByteString' (Public.knownTeamFeatureName @a), toByteString' lockStatus] + . reqmod diff --git a/services/spar/src/Spar/Intra/Galley.hs b/services/spar/src/Spar/Intra/Galley.hs index d8a0bc6291c..f4984b2b059 100644 --- a/services/spar/src/Spar/Intra/Galley.hs +++ b/services/spar/src/Spar/Intra/Galley.hs @@ -31,7 +31,13 @@ import Imports import Network.HTTP.Types.Method import Spar.Error import qualified System.Logger.Class as Log -import Wire.API.Team.Feature (TeamFeatureName (..), TeamFeatureStatus, TeamFeatureStatusNoConfig (..), TeamFeatureStatusValue (..)) +import Wire.API.Team.Feature + ( IncludeLockStatus (..), + TeamFeatureName (..), + TeamFeatureStatus, + TeamFeatureStatusNoConfig (..), + TeamFeatureStatusValue (..), + ) ---------------------------------------------------------------------- @@ -88,7 +94,7 @@ isEmailValidationEnabledTeam tid = do resp <- call $ method GET . paths ["i", "teams", toByteString' tid, "features", "validateSAMLemails"] pure ( (statusCode resp == 200) - && ( responseJsonMaybe @(TeamFeatureStatus 'TeamFeatureValidateSAMLEmails) resp + && ( responseJsonMaybe @(TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureValidateSAMLEmails) resp == Just (TeamFeatureStatusNoConfig TeamFeatureEnabled) ) ) diff --git a/tools/stern/src/Stern/API.hs b/tools/stern/src/Stern/API.hs index 27e8e727098..ead623edff2 100644 --- a/tools/stern/src/Stern/API.hs +++ b/tools/stern/src/Stern/API.hs @@ -594,25 +594,25 @@ getTeamAdminInfo = liftM (json . toAdminInfo) . Intra.getTeamInfo getTeamFeatureFlagH :: forall (a :: Public.TeamFeatureName). ( Public.KnownTeamFeatureName a, - FromJSON (Public.TeamFeatureStatus a), - ToJSON (Public.TeamFeatureStatus a), - Typeable (Public.TeamFeatureStatus a) + FromJSON (Public.TeamFeatureStatus 'Public.WithoutLockStatus a), + ToJSON (Public.TeamFeatureStatus 'Public.WithoutLockStatus a), + Typeable (Public.TeamFeatureStatus 'Public.WithoutLockStatus a) ) => TeamId -> Handler Response getTeamFeatureFlagH tid = - json <$> Intra.getTeamFeatureFlag @a tid + json <$> Intra.getTeamFeatureFlag @'Public.WithoutLockStatus @a tid setTeamFeatureFlagH :: forall (a :: Public.TeamFeatureName). ( Public.KnownTeamFeatureName a, - FromJSON (Public.TeamFeatureStatus a), - ToJSON (Public.TeamFeatureStatus a) + FromJSON (Public.TeamFeatureStatus 'Public.WithoutLockStatus a), + ToJSON (Public.TeamFeatureStatus 'Public.WithoutLockStatus a) ) => - TeamId ::: JsonRequest (Public.TeamFeatureStatus a) ::: JSON -> + TeamId ::: JsonRequest (Public.TeamFeatureStatus 'Public.WithoutLockStatus a) ::: JSON -> Handler Response setTeamFeatureFlagH (tid ::: req ::: _) = do - status :: Public.TeamFeatureStatus a <- parseBody req !>> mkError status400 "client-error" + status :: Public.TeamFeatureStatus 'Public.WithoutLockStatus a <- parseBody req !>> mkError status400 "client-error" empty <$ Intra.setTeamFeatureFlag @a tid status getTeamFeatureFlagNoConfigH :: @@ -755,9 +755,9 @@ noSuchUser = ifNothing (mkError status404 "no-user" "No such user") mkFeaturePutGetRoute :: forall (a :: Public.TeamFeatureName). ( Public.KnownTeamFeatureName a, - FromJSON (Public.TeamFeatureStatus a), - ToJSON (Public.TeamFeatureStatus a), - Typeable (Public.TeamFeatureStatus a) + FromJSON (Public.TeamFeatureStatus 'Public.WithoutLockStatus a), + ToJSON (Public.TeamFeatureStatus 'Public.WithoutLockStatus a), + Typeable (Public.TeamFeatureStatus 'Public.WithoutLockStatus a) ) => Routes Doc.ApiBuilder Handler () mkFeaturePutGetRoute = do @@ -774,7 +774,7 @@ mkFeaturePutGetRoute = do put ("/teams/:tid/features/" <> toByteString' featureName) (continue (setTeamFeatureFlagH @a)) $ capture "tid" - .&. jsonRequest @(Public.TeamFeatureStatus a) + .&. jsonRequest @(Public.TeamFeatureStatus 'Public.WithoutLockStatus a) .&. accept "application" "json" document "PUT" "setTeamFeatureFlag" $ do summary "Disable / enable feature flag for a given team" diff --git a/tools/stern/src/Stern/Intra.hs b/tools/stern/src/Stern/Intra.hs index e930aa76e03..2139f16750e 100644 --- a/tools/stern/src/Stern/Intra.hs +++ b/tools/stern/src/Stern/Intra.hs @@ -452,13 +452,13 @@ setBlacklistStatus status emailOrPhone = do statusToMethod True = POST getTeamFeatureFlag :: - forall (a :: Public.TeamFeatureName). + forall (ps :: Public.IncludeLockStatus) (a :: Public.TeamFeatureName). ( Public.KnownTeamFeatureName a, - Typeable (Public.TeamFeatureStatus a), - FromJSON (Public.TeamFeatureStatus a) + Typeable (Public.TeamFeatureStatus ps a), + FromJSON (Public.TeamFeatureStatus ps a) ) => TeamId -> - Handler (Public.TeamFeatureStatus a) + Handler (Public.TeamFeatureStatus ps a) getTeamFeatureFlag tid = do info $ msg "Getting team feature status" gly <- view galley @@ -467,17 +467,17 @@ getTeamFeatureFlag tid = do . paths ["/i/teams", toByteString' tid, "features", toByteString' (Public.knownTeamFeatureName @a)] resp <- catchRpcErrors $ rpc' "galley" gly req case Bilge.statusCode resp of - 200 -> pure $ responseJsonUnsafe @(Public.TeamFeatureStatus a) resp + 200 -> pure $ responseJsonUnsafe @(Public.TeamFeatureStatus ps a) resp 404 -> throwE (mkError status404 "bad-upstream" "team doesnt exist") _ -> throwE (mkError status502 "bad-upstream" "bad response") setTeamFeatureFlag :: forall (a :: Public.TeamFeatureName). ( Public.KnownTeamFeatureName a, - ToJSON (Public.TeamFeatureStatus a) + ToJSON (Public.TeamFeatureStatus 'Public.WithoutLockStatus a) ) => TeamId -> - Public.TeamFeatureStatus a -> + Public.TeamFeatureStatus 'Public.WithoutLockStatus a -> Handler () setTeamFeatureFlag tid status = do info $ msg "Setting team feature status" From b4bcb3dffb178396c194372a422e1fa25b7378fc Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Fri, 26 Nov 2021 12:15:33 +0100 Subject: [PATCH 12/28] Use minio helm chart from charts.min.io instead of helm.min.io (#1944) * Use minio helm chart from charts.min.io instead of helm.min.io * Add note about change in options for fake-aws-s3 * charts/fake-aws-s3: Dynamically figure out consoleAdmin creds * charts/fake-aws: Remove dependecy from minio.defaultBucket Assumes that first bucket is the one required by cargohold * charts/fake-aws-s3: Install minio in standalone mode * charts/fake-aws-s3: Lower the memory request for minio node * fake-aws-s3: Use minio-client to recreate any missing users/buckets --- changelog.d/0-release-notes/minio-helm | 1 + changelog.d/5-internal/minio-helm | 1 + charts/fake-aws-s3/requirements.yaml | 4 ++-- charts/fake-aws-s3/templates/reaper.yaml | 27 ++++++++++++++++++++---- charts/fake-aws-s3/values.yaml | 18 ++++++++++++---- charts/fake-aws/templates/NOTES.txt | 2 +- 6 files changed, 42 insertions(+), 11 deletions(-) create mode 100644 changelog.d/0-release-notes/minio-helm create mode 100644 changelog.d/5-internal/minio-helm diff --git a/changelog.d/0-release-notes/minio-helm b/changelog.d/0-release-notes/minio-helm new file mode 100644 index 00000000000..248b77797f7 --- /dev/null +++ b/changelog.d/0-release-notes/minio-helm @@ -0,0 +1 @@ +Breaking change to the `fake-aws-s3` helm chart. We now use minio helm chart from https://charts.min.io. The options are documented here: https://github.com/minio/minio/tree/master/helm/minio \ No newline at end of file diff --git a/changelog.d/5-internal/minio-helm b/changelog.d/5-internal/minio-helm new file mode 100644 index 00000000000..d1dfc08a0bd --- /dev/null +++ b/changelog.d/5-internal/minio-helm @@ -0,0 +1 @@ +Use minio helm chart in fake-aws-s3 from charts.min.io instead of helm.min.io, the latter seems to be down \ No newline at end of file diff --git a/charts/fake-aws-s3/requirements.yaml b/charts/fake-aws-s3/requirements.yaml index 815b3023d00..da4723909d2 100644 --- a/charts/fake-aws-s3/requirements.yaml +++ b/charts/fake-aws-s3/requirements.yaml @@ -1,4 +1,4 @@ dependencies: - name: minio - version: 8.0.3 - repository: https://helm.min.io/ + version: 3.2.0 + repository: https://charts.min.io/ diff --git a/charts/fake-aws-s3/templates/reaper.yaml b/charts/fake-aws-s3/templates/reaper.yaml index 0d668c0d5eb..9d7759eaadd 100644 --- a/charts/fake-aws-s3/templates/reaper.yaml +++ b/charts/fake-aws-s3/templates/reaper.yaml @@ -17,17 +17,36 @@ spec: labels: app: {{ template "fullname" . }}-reaper spec: + volumes: + - name: minio-configuration + projected: + # These are created by the minio chart and used for create buckets and + # users after deployment. + sources: + - configMap: + name: {{ .Values.minio.fullnameOverride }} + - secret: + name: {{ .Values.minio.fullnameOverride }} containers: - name: initiate-fake-aws-s3 - image: mesosphere/aws-cli:1.14.5 + image: "{{ .Values.minio.mcImage.repository }}:{{ .Values.minio.mcImage.tag }}" + imagePullPolicy: {{ .Values.minio.mcImage.pullPolicy }} command: [/bin/sh] args: - -c - | - echo 'Creating AWS resources' + echo 'Creating MinIO Users and Buckets' while true do - AWS_SECRET_ACCESS_KEY={{ .Values.minio.secretKey }} AWS_ACCESS_KEY_ID={{ .Values.minio.accessKey }} aws s3 --endpoint http://{{ .Values.minio.fullnameOverride }}:9000 mb s3://{{ .Values.minio.defaultBucket.name }} | grep -ev "BucketAlreadyOwnedByYou" + /bin/sh /config/initialize + /bin/sh /config/add-user sleep 10 done - + env: + - name: MINIO_ENDPOINT + value: {{ .Values.minio.fullnameOverride | quote }} + - name: MINIO_PORT + value: {{ .Values.minio.service.port | quote }} + volumeMounts: + - name: minio-configuration + mountPath: /config diff --git a/charts/fake-aws-s3/values.yaml b/charts/fake-aws-s3/values.yaml index 2e0d4582351..3c7ffd4774d 100644 --- a/charts/fake-aws-s3/values.yaml +++ b/charts/fake-aws-s3/values.yaml @@ -1,14 +1,24 @@ # See defaults in https://github.com/helm/charts/tree/master/stable/minio minio: + mcImage: + repository: quay.io/minio/mc + tag: RELEASE.2021-10-07T04-19-58Z + pullPolicy: IfNotPresent fullnameOverride: fake-aws-s3 - accessKey: dummykey - secretKey: dummysecret + service: + port: "9000" + mode: standalone + users: + - accessKey: dummykey + secretKey: dummysecret + policy: consoleAdmin persistence: enabled: false environment: MINIO_BROWSER: "off" - defaultBucket: - name: dummy-bucket + resources: + requests: + memory: 200Mi buckets: - name: dummy-bucket purge: true diff --git a/charts/fake-aws/templates/NOTES.txt b/charts/fake-aws/templates/NOTES.txt index 212cdc5af1b..81d394e5dda 100644 --- a/charts/fake-aws/templates/NOTES.txt +++ b/charts/fake-aws/templates/NOTES.txt @@ -20,7 +20,7 @@ SQS : http://fake-aws-sqs:{{ index .Values "fake-aws-sqs" "service" "httpPo {{- end }} {{- if index .Values "fake-aws-s3" "enabled" }} S3 : http://fake-aws-s3:9000 - bucket: {{ index .Values "fake-aws-s3" "minio" "defaultBucket" "name" }} + bucket: {{ index .Values "fake-aws-s3" "minio" "buckets" 0 "name" }} {{- end }} {{- if index .Values "fake-aws-ses" "enabled" }} SES : http://fake-aws-ses:{{ index .Values "fake-aws-ses" "service" "externalPort" }} From f47908cf1ab06373e550db40dbfb65eecb3c7456 Mon Sep 17 00:00:00 2001 From: fisx Date: Fri, 26 Nov 2021 15:15:50 +0100 Subject: [PATCH 13/28] Revert "(Un-)lock Status for Self-Deleting Messages (#1937)" (#1946) This reverts commit 39f45ffe1906dd8de35d9a1e3e34db394fd294cb. --- changelog.d/0-release-notes/pr-1937 | 1 - ...e-config-seld-del-msgs-with-payment-status | 1 - .../set-payment-status-self-del-msgs | 1 - .../set-payment-status-for-self-del-msgs | 1 - docs/reference/cassandra-schema.cql | 1 - libs/galley-types/src/Galley/Types/Teams.hs | 10 +- .../src/Wire/API/Routes/Internal/Brig.hs | 4 +- .../src/Wire/API/Routes/Public/Galley.hs | 44 +-- .../src/Wire/API/Routes/Public/LegalHold.hs | 4 +- libs/wire-api/src/Wire/API/Swagger.hs | 1 - libs/wire-api/src/Wire/API/Team/Feature.hs | 147 ++-------- .../golden/Test/Wire/API/Golden/Generator.hs | 4 +- .../unit/Test/Wire/API/Roundtrip/Aeson.hs | 24 +- services/brig/src/Brig/IO/Intra.hs | 4 +- services/brig/src/Brig/Options.hs | 4 +- services/galley/galley.cabal | 1 - services/galley/schema/src/Main.hs | 6 +- .../src/V55_SelfDeletingMessagesLockStatus.hs | 33 --- services/galley/src/Galley/API/Error.hs | 5 - services/galley/src/Galley/API/Internal.hs | 104 +++---- services/galley/src/Galley/API/LegalHold.hs | 2 +- services/galley/src/Galley/API/Public.hs | 46 +-- services/galley/src/Galley/API/Teams.hs | 4 +- .../galley/src/Galley/API/Teams/Features.hs | 277 +++++++----------- services/galley/src/Galley/Cassandra.hs | 2 +- .../src/Galley/Cassandra/TeamFeatures.hs | 93 ++---- .../galley/src/Galley/Data/TeamFeatures.hs | 32 +- .../src/Galley/Effects/TeamFeatureStore.hs | 76 ++--- services/galley/test/integration/API/Teams.hs | 10 +- .../test/integration/API/Teams/Feature.hs | 166 ++++------- .../test/integration/API/Teams/LegalHold.hs | 6 +- .../API/Teams/LegalHold/DisabledByDefault.hs | 10 +- .../test/integration/API/Util/TeamFeature.hs | 53 ++-- services/spar/src/Spar/Intra/Galley.hs | 10 +- tools/stern/src/Stern/API.hs | 24 +- tools/stern/src/Stern/Intra.hs | 14 +- 36 files changed, 398 insertions(+), 827 deletions(-) delete mode 100644 changelog.d/0-release-notes/pr-1937 delete mode 100644 changelog.d/1-api-changes/get-feature-config-seld-del-msgs-with-payment-status delete mode 100644 changelog.d/1-api-changes/set-payment-status-self-del-msgs delete mode 100644 changelog.d/2-features/set-payment-status-for-self-del-msgs delete mode 100644 services/galley/schema/src/V55_SelfDeletingMessagesLockStatus.hs diff --git a/changelog.d/0-release-notes/pr-1937 b/changelog.d/0-release-notes/pr-1937 deleted file mode 100644 index 85e7a39820c..00000000000 --- a/changelog.d/0-release-notes/pr-1937 +++ /dev/null @@ -1 +0,0 @@ -If you have `selfDeletingMessages` configured in `galley.yaml`, add `lockStatus: unlocked`. diff --git a/changelog.d/1-api-changes/get-feature-config-seld-del-msgs-with-payment-status b/changelog.d/1-api-changes/get-feature-config-seld-del-msgs-with-payment-status deleted file mode 100644 index d1855d92dde..00000000000 --- a/changelog.d/1-api-changes/get-feature-config-seld-del-msgs-with-payment-status +++ /dev/null @@ -1 +0,0 @@ -get team feature config for self deleting messages response includes lock status diff --git a/changelog.d/1-api-changes/set-payment-status-self-del-msgs b/changelog.d/1-api-changes/set-payment-status-self-del-msgs deleted file mode 100644 index 3cca58aab4f..00000000000 --- a/changelog.d/1-api-changes/set-payment-status-self-del-msgs +++ /dev/null @@ -1 +0,0 @@ -new internal endpoints for setting the lock status of self deleting messages diff --git a/changelog.d/2-features/set-payment-status-for-self-del-msgs b/changelog.d/2-features/set-payment-status-for-self-del-msgs deleted file mode 100644 index 1b0c9e647be..00000000000 --- a/changelog.d/2-features/set-payment-status-for-self-del-msgs +++ /dev/null @@ -1 +0,0 @@ -Lock status for the self deleting messages feature can be set internally by ibis and customer support diff --git a/docs/reference/cassandra-schema.cql b/docs/reference/cassandra-schema.cql index 43505d0d58f..7b70e2f4642 100644 --- a/docs/reference/cassandra-schema.cql +++ b/docs/reference/cassandra-schema.cql @@ -422,7 +422,6 @@ CREATE TABLE galley_test.team_features ( file_sharing int, legalhold_status int, search_visibility_status int, - self_deleting_messages_lock_status int, self_deleting_messages_status int, self_deleting_messages_ttl int, sso_status int, diff --git a/libs/galley-types/src/Galley/Types/Teams.hs b/libs/galley-types/src/Galley/Types/Teams.hs index d1b0d1851ab..8e727e90a1d 100644 --- a/libs/galley-types/src/Galley/Types/Teams.hs +++ b/libs/galley-types/src/Galley/Types/Teams.hs @@ -212,11 +212,11 @@ data FeatureFlags = FeatureFlags { _flagSSO :: !FeatureSSO, _flagLegalHold :: !FeatureLegalHold, _flagTeamSearchVisibility :: !FeatureTeamSearchVisibility, - _flagAppLockDefaults :: !(Defaults (TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureAppLock)), - _flagClassifiedDomains :: !(TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureClassifiedDomains), - _flagFileSharing :: !(Defaults (TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureFileSharing)), - _flagConferenceCalling :: !(Defaults (TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureConferenceCalling)), - _flagSelfDeletingMessages :: !(Defaults (TeamFeatureStatus 'WithLockStatus 'TeamFeatureSelfDeletingMessages)) + _flagAppLockDefaults :: !(Defaults (TeamFeatureStatus 'TeamFeatureAppLock)), + _flagClassifiedDomains :: !(TeamFeatureStatus 'TeamFeatureClassifiedDomains), + _flagFileSharing :: !(Defaults (TeamFeatureStatus 'TeamFeatureFileSharing)), + _flagConferenceCalling :: !(Defaults (TeamFeatureStatus 'TeamFeatureConferenceCalling)), + _flagSelfDeletingMessages :: !(Defaults (TeamFeatureStatus 'TeamFeatureSelfDeletingMessages)) } deriving (Eq, Show, Generic) diff --git a/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs b/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs index 5027a554056..51e34b18d40 100644 --- a/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs +++ b/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs @@ -66,7 +66,7 @@ type GetAccountFeatureConfig = :> Capture "uid" UserId :> "features" :> "conferenceCalling" - :> Get '[Servant.JSON] (ApiFt.TeamFeatureStatus 'ApiFt.WithLockStatus 'ApiFt.TeamFeatureConferenceCalling) + :> Get '[Servant.JSON] (ApiFt.TeamFeatureStatus 'ApiFt.TeamFeatureConferenceCalling) type PutAccountFeatureConfig = Summary @@ -75,7 +75,7 @@ type PutAccountFeatureConfig = :> Capture "uid" UserId :> "features" :> "conferenceCalling" - :> Servant.ReqBody '[Servant.JSON] (ApiFt.TeamFeatureStatus 'ApiFt.WithoutLockStatus 'ApiFt.TeamFeatureConferenceCalling) + :> Servant.ReqBody '[Servant.JSON] (ApiFt.TeamFeatureStatus 'ApiFt.TeamFeatureConferenceCalling) :> Put '[Servant.JSON] NoContent type DeleteAccountFeatureConfig = diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs b/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs index ff1dc2ed877..7aafbfa7bf7 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs @@ -623,7 +623,7 @@ data Api routes = Api :- FeatureStatusPut 'TeamFeatureSearchVisibility, teamFeatureStatusSearchVisibilityDeprecatedGet :: routes - :- FeatureStatusDeprecatedGet 'WithoutLockStatus 'TeamFeatureSearchVisibility, + :- FeatureStatusDeprecatedGet 'TeamFeatureSearchVisibility, teamFeatureStatusSearchVisibilityDeprecatedPut :: routes :- FeatureStatusDeprecatedPut 'TeamFeatureSearchVisibility, @@ -632,13 +632,13 @@ data Api routes = Api :- FeatureStatusGet 'TeamFeatureValidateSAMLEmails, teamFeatureStatusValidateSAMLEmailsDeprecatedGet :: routes - :- FeatureStatusDeprecatedGet 'WithoutLockStatus 'TeamFeatureValidateSAMLEmails, + :- FeatureStatusDeprecatedGet 'TeamFeatureValidateSAMLEmails, teamFeatureStatusDigitalSignaturesGet :: routes :- FeatureStatusGet 'TeamFeatureDigitalSignatures, teamFeatureStatusDigitalSignaturesDeprecatedGet :: routes - :- FeatureStatusDeprecatedGet 'WithoutLockStatus 'TeamFeatureDigitalSignatures, + :- FeatureStatusDeprecatedGet 'TeamFeatureDigitalSignatures, teamFeatureStatusAppLockGet :: routes :- FeatureStatusGet 'TeamFeatureAppLock, @@ -668,34 +668,34 @@ data Api routes = Api :- AllFeatureConfigsGet, featureConfigLegalHoldGet :: routes - :- FeatureConfigGet 'WithoutLockStatus 'TeamFeatureLegalHold, + :- FeatureConfigGet 'TeamFeatureLegalHold, featureConfigSSOGet :: routes - :- FeatureConfigGet 'WithoutLockStatus 'TeamFeatureSSO, + :- FeatureConfigGet 'TeamFeatureSSO, featureConfigSearchVisibilityGet :: routes - :- FeatureConfigGet 'WithoutLockStatus 'TeamFeatureSearchVisibility, + :- FeatureConfigGet 'TeamFeatureSearchVisibility, featureConfigValidateSAMLEmailsGet :: routes - :- FeatureConfigGet 'WithoutLockStatus 'TeamFeatureValidateSAMLEmails, + :- FeatureConfigGet 'TeamFeatureValidateSAMLEmails, featureConfigDigitalSignaturesGet :: routes - :- FeatureConfigGet 'WithoutLockStatus 'TeamFeatureDigitalSignatures, + :- FeatureConfigGet 'TeamFeatureDigitalSignatures, featureConfigAppLockGet :: routes - :- FeatureConfigGet 'WithoutLockStatus 'TeamFeatureAppLock, + :- FeatureConfigGet 'TeamFeatureAppLock, featureConfigFileSharingGet :: routes - :- FeatureConfigGet 'WithoutLockStatus 'TeamFeatureFileSharing, + :- FeatureConfigGet 'TeamFeatureFileSharing, featureConfigClassifiedDomainsGet :: routes - :- FeatureConfigGet 'WithoutLockStatus 'TeamFeatureClassifiedDomains, + :- FeatureConfigGet 'TeamFeatureClassifiedDomains, featureConfigConferenceCallingGet :: routes - :- FeatureConfigGet 'WithoutLockStatus 'TeamFeatureConferenceCalling, + :- FeatureConfigGet 'TeamFeatureConferenceCalling, featureConfigSelfDeletingMessagesGet :: routes - :- FeatureConfigGet 'WithLockStatus 'TeamFeatureSelfDeletingMessages + :- FeatureConfigGet 'TeamFeatureSelfDeletingMessages } deriving (Generic) @@ -708,7 +708,7 @@ type FeatureStatusGet featureName = :> Capture "tid" TeamId :> "features" :> KnownTeamFeatureNameSymbol featureName - :> Get '[Servant.JSON] (TeamFeatureStatus 'WithLockStatus featureName) + :> Get '[Servant.JSON] (TeamFeatureStatus featureName) type FeatureStatusPut featureName = Summary (AppendSymbol "Put config for " (KnownTeamFeatureNameSymbol featureName)) @@ -717,18 +717,18 @@ type FeatureStatusPut featureName = :> Capture "tid" TeamId :> "features" :> KnownTeamFeatureNameSymbol featureName - :> ReqBody '[Servant.JSON] (TeamFeatureStatus 'WithoutLockStatus featureName) - :> Put '[Servant.JSON] (TeamFeatureStatus 'WithoutLockStatus featureName) + :> ReqBody '[Servant.JSON] (TeamFeatureStatus featureName) + :> Put '[Servant.JSON] (TeamFeatureStatus featureName) -- | A type for a GET endpoint for a feature with a deprecated path -type FeatureStatusDeprecatedGet ps featureName = +type FeatureStatusDeprecatedGet featureName = Summary (AppendSymbol "[deprecated] Get config for " (KnownTeamFeatureNameSymbol featureName)) :> ZUser :> "teams" :> Capture "tid" TeamId :> "features" :> DeprecatedFeatureName featureName - :> Get '[Servant.JSON] (TeamFeatureStatus ps featureName) + :> Get '[Servant.JSON] (TeamFeatureStatus featureName) -- | A type for a PUT endpoint for a feature with a deprecated path type FeatureStatusDeprecatedPut featureName = @@ -738,15 +738,15 @@ type FeatureStatusDeprecatedPut featureName = :> Capture "tid" TeamId :> "features" :> DeprecatedFeatureName featureName - :> ReqBody '[Servant.JSON] (TeamFeatureStatus 'WithoutLockStatus featureName) - :> Put '[Servant.JSON] (TeamFeatureStatus 'WithoutLockStatus featureName) + :> ReqBody '[Servant.JSON] (TeamFeatureStatus featureName) + :> Put '[Servant.JSON] (TeamFeatureStatus featureName) -type FeatureConfigGet ps featureName = +type FeatureConfigGet featureName = Summary (AppendSymbol "Get feature config for feature " (KnownTeamFeatureNameSymbol featureName)) :> ZUser :> "feature-configs" :> KnownTeamFeatureNameSymbol featureName - :> Get '[Servant.JSON] (TeamFeatureStatus ps featureName) + :> Get '[Servant.JSON] (TeamFeatureStatus featureName) type AllFeatureConfigsGet = Summary "Get configurations of all features" diff --git a/libs/wire-api/src/Wire/API/Routes/Public/LegalHold.hs b/libs/wire-api/src/Wire/API/Routes/Public/LegalHold.hs index 6c3db162ae9..6bb24b75430 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/LegalHold.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/LegalHold.hs @@ -52,9 +52,9 @@ type PublicAPI = type InternalAPI = "i" :> "teams" :> Capture "tid" TeamId :> "legalhold" - :> Get '[JSON] (TeamFeatureStatus 'WithLockStatus 'TeamFeatureLegalHold) + :> Get '[JSON] (TeamFeatureStatus 'TeamFeatureLegalHold) :<|> "i" :> "teams" :> Capture "tid" TeamId :> "legalhold" - :> ReqBody '[JSON] (TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureLegalHold) + :> ReqBody '[JSON] (TeamFeatureStatus 'TeamFeatureLegalHold) :> Put '[] NoContent swaggerDoc :: Swagger diff --git a/libs/wire-api/src/Wire/API/Swagger.hs b/libs/wire-api/src/Wire/API/Swagger.hs index 68160851619..f746c3465c3 100644 --- a/libs/wire-api/src/Wire/API/Swagger.hs +++ b/libs/wire-api/src/Wire/API/Swagger.hs @@ -129,7 +129,6 @@ models = Team.Feature.modelTeamFeatureAppLockConfig, Team.Feature.modelTeamFeatureClassifiedDomainsConfig, Team.Feature.modelTeamFeatureSelfDeletingMessagesConfig, - Team.Feature.modelLockStatus, Team.Invitation.modelTeamInvitation, Team.Invitation.modelTeamInvitationList, Team.Invitation.modelTeamInvitationRequest, diff --git a/libs/wire-api/src/Wire/API/Team/Feature.hs b/libs/wire-api/src/Wire/API/Team/Feature.hs index aa1bdc89726..f466fe3102c 100644 --- a/libs/wire-api/src/Wire/API/Team/Feature.hs +++ b/libs/wire-api/src/Wire/API/Team/Feature.hs @@ -30,12 +30,8 @@ module Wire.API.Team.Feature KnownTeamFeatureName (..), TeamFeatureStatusNoConfig (..), TeamFeatureStatusWithConfig (..), - TeamFeatureStatusWithConfigAndLockStatus (..), HasDeprecatedFeatureName (..), AllFeatureConfigs (..), - LockStatus (..), - LockStatusValue (..), - IncludeLockStatus (..), defaultAppLockStatus, defaultClassifiedDomains, defaultSelfDeletingMessagesStatus, @@ -48,9 +44,7 @@ module Wire.API.Team.Feature modelTeamFeatureAppLockConfig, modelTeamFeatureClassifiedDomainsConfig, modelTeamFeatureSelfDeletingMessagesConfig, - modelTeamFeatureStatusWithConfigAndLockStatus, modelForTeamFeature, - modelLockStatus, ) where @@ -58,9 +52,8 @@ import qualified Cassandra.CQL as Cass import Control.Lens.Combinators (dimap) import qualified Data.Aeson as Aeson import qualified Data.Attoparsec.ByteString as Parser -import Data.ByteString.Conversion (FromByteString (..), ToByteString (..), fromByteString, toByteString') +import Data.ByteString.Conversion (FromByteString (..), ToByteString (..), toByteString') import Data.Domain (Domain) -import Data.Either.Extra (maybeToEither) import Data.Kind (Constraint) import Data.Schema import Data.String.Conversions (cs) @@ -71,7 +64,6 @@ import qualified Data.Text.Encoding as T import Deriving.Aeson import GHC.TypeLits (Symbol) import Imports -import Servant (FromHttpApiData (..)) import Test.QuickCheck.Arbitrary (arbitrary) import Wire.API.Arbitrary (Arbitrary, GenericUniform (..)) @@ -280,8 +272,8 @@ instance Cass.Cql TeamFeatureStatusValue where ctype = Cass.Tagged Cass.IntColumn fromCql (Cass.CqlInt n) = case n of - 0 -> pure TeamFeatureDisabled - 1 -> pure TeamFeatureEnabled + 0 -> pure $ TeamFeatureDisabled + 1 -> pure $ TeamFeatureEnabled _ -> Left "fromCql: Invalid TeamFeatureStatusValue" fromCql _ = Left "fromCql: TeamFeatureStatusValue: CqlInt expected" @@ -291,22 +283,19 @@ instance Cass.Cql TeamFeatureStatusValue where ---------------------------------------------------------------------- -- TeamFeatureStatus -data IncludeLockStatus = WithLockStatus | WithoutLockStatus +type family TeamFeatureStatus (a :: TeamFeatureName) :: * where + TeamFeatureStatus 'TeamFeatureLegalHold = TeamFeatureStatusNoConfig + TeamFeatureStatus 'TeamFeatureSSO = TeamFeatureStatusNoConfig + TeamFeatureStatus 'TeamFeatureSearchVisibility = TeamFeatureStatusNoConfig + TeamFeatureStatus 'TeamFeatureValidateSAMLEmails = TeamFeatureStatusNoConfig + TeamFeatureStatus 'TeamFeatureDigitalSignatures = TeamFeatureStatusNoConfig + TeamFeatureStatus 'TeamFeatureAppLock = TeamFeatureStatusWithConfig TeamFeatureAppLockConfig + TeamFeatureStatus 'TeamFeatureFileSharing = TeamFeatureStatusNoConfig + TeamFeatureStatus 'TeamFeatureClassifiedDomains = TeamFeatureStatusWithConfig TeamFeatureClassifiedDomainsConfig + TeamFeatureStatus 'TeamFeatureConferenceCalling = TeamFeatureStatusNoConfig + TeamFeatureStatus 'TeamFeatureSelfDeletingMessages = TeamFeatureStatusWithConfig TeamFeatureSelfDeletingMessagesConfig -type family TeamFeatureStatus (ps :: IncludeLockStatus) (a :: TeamFeatureName) :: * where - TeamFeatureStatus _ 'TeamFeatureLegalHold = TeamFeatureStatusNoConfig - TeamFeatureStatus _ 'TeamFeatureSSO = TeamFeatureStatusNoConfig - TeamFeatureStatus _ 'TeamFeatureSearchVisibility = TeamFeatureStatusNoConfig - TeamFeatureStatus _ 'TeamFeatureValidateSAMLEmails = TeamFeatureStatusNoConfig - TeamFeatureStatus _ 'TeamFeatureDigitalSignatures = TeamFeatureStatusNoConfig - TeamFeatureStatus _ 'TeamFeatureAppLock = TeamFeatureStatusWithConfig TeamFeatureAppLockConfig - TeamFeatureStatus _ 'TeamFeatureFileSharing = TeamFeatureStatusNoConfig - TeamFeatureStatus _ 'TeamFeatureClassifiedDomains = TeamFeatureStatusWithConfig TeamFeatureClassifiedDomainsConfig - TeamFeatureStatus _ 'TeamFeatureConferenceCalling = TeamFeatureStatusNoConfig - TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureSelfDeletingMessages = TeamFeatureStatusWithConfig TeamFeatureSelfDeletingMessagesConfig - TeamFeatureStatus 'WithLockStatus 'TeamFeatureSelfDeletingMessages = TeamFeatureStatusWithConfigAndLockStatus TeamFeatureSelfDeletingMessagesConfig - -type FeatureHasNoConfig (ps :: IncludeLockStatus) (a :: TeamFeatureName) = (TeamFeatureStatus ps a ~ TeamFeatureStatusNoConfig) :: Constraint +type FeatureHasNoConfig (a :: TeamFeatureName) = (TeamFeatureStatus a ~ TeamFeatureStatusNoConfig) :: Constraint -- if you add a new constructor here, don't forget to add it to the swagger (1.2) docs in "Wire.API.Swagger"! modelForTeamFeature :: TeamFeatureName -> Doc.Model @@ -371,32 +360,6 @@ instance ToSchema cfg => ToSchema (TeamFeatureStatusWithConfig cfg) where <$> tfwcStatus .= field "status" schema <*> tfwcConfig .= field "config" schema -data TeamFeatureStatusWithConfigAndLockStatus (cfg :: *) = TeamFeatureStatusWithConfigAndLockStatus - { tfwcapsStatus :: TeamFeatureStatusValue, - tfwcapsConfig :: cfg, - tfwcapsLockStatus :: LockStatusValue - } - deriving stock (Eq, Show, Generic, Typeable) - deriving (ToJSON, FromJSON, S.ToSchema) via (Schema (TeamFeatureStatusWithConfigAndLockStatus cfg)) - -instance Arbitrary cfg => Arbitrary (TeamFeatureStatusWithConfigAndLockStatus cfg) where - arbitrary = TeamFeatureStatusWithConfigAndLockStatus <$> arbitrary <*> arbitrary <*> arbitrary - -modelTeamFeatureStatusWithConfigAndLockStatus :: TeamFeatureName -> Doc.Model -> Doc.Model -modelTeamFeatureStatusWithConfigAndLockStatus name cfgModel = Doc.defineModel (cs $ show name) $ do - Doc.description $ "Status and config of " <> cs (show name) - Doc.property "status" typeTeamFeatureStatusValue $ Doc.description "status" - Doc.property "config" (Doc.ref cfgModel) $ Doc.description "config" - Doc.property "lockStatus" typeLockStatusValue $ Doc.description "config" - -instance ToSchema cfg => ToSchema (TeamFeatureStatusWithConfigAndLockStatus cfg) where - schema = - object "TeamFeatureStatusWithConfigAndLockStatus" $ - TeamFeatureStatusWithConfigAndLockStatus - <$> tfwcapsStatus .= field "status" schema - <*> tfwcapsConfig .= field "config" schema - <*> tfwcapsLockStatus .= field "lockStatus" schema - ---------------------------------------------------------------------- -- TeamFeatureClassifiedDomainsConfig @@ -420,10 +383,7 @@ modelTeamFeatureClassifiedDomainsConfig = Doc.property "domains" (Doc.array Doc.string') $ Doc.description "domains" defaultClassifiedDomains :: TeamFeatureStatusWithConfig TeamFeatureClassifiedDomainsConfig -defaultClassifiedDomains = - TeamFeatureStatusWithConfig - TeamFeatureDisabled - (TeamFeatureClassifiedDomainsConfig []) +defaultClassifiedDomains = TeamFeatureStatusWithConfig TeamFeatureDisabled (TeamFeatureClassifiedDomainsConfig []) ---------------------------------------------------------------------- -- TeamFeatureAppLockConfig @@ -485,82 +445,11 @@ modelTeamFeatureSelfDeletingMessagesConfig = Doc.defineModel "TeamFeatureSelfDeletingMessagesConfig" $ do Doc.property "enforcedTimeoutSeconds" Doc.int32' $ Doc.description "optional; default: `0` (no enforcement)" -defaultSelfDeletingMessagesStatus :: TeamFeatureStatusWithConfigAndLockStatus TeamFeatureSelfDeletingMessagesConfig +defaultSelfDeletingMessagesStatus :: TeamFeatureStatusWithConfig TeamFeatureSelfDeletingMessagesConfig defaultSelfDeletingMessagesStatus = - TeamFeatureStatusWithConfigAndLockStatus + TeamFeatureStatusWithConfig TeamFeatureEnabled (TeamFeatureSelfDeletingMessagesConfig 0) - Unlocked - ----------------------------------------------------------------------- --- LockStatus - -instance FromHttpApiData LockStatusValue where - parseUrlPiece = maybeToEither "Invalid lock status" . fromByteString . cs - -data LockStatusValue = Locked | Unlocked - deriving stock (Eq, Show, Generic) - deriving (Arbitrary) via (GenericUniform LockStatusValue) - deriving (ToJSON, FromJSON, S.ToSchema) via (Schema LockStatusValue) - -newtype LockStatus = LockStatus - { lockStatus :: LockStatusValue - } - deriving stock (Eq, Show, Generic) - deriving (FromJSON, ToJSON, S.ToSchema) via (Schema LockStatus) - deriving (Arbitrary) via (GenericUniform LockStatus) - -instance ToSchema LockStatus where - schema = - object "LockStatus" $ - LockStatus - <$> lockStatus .= field "lockStatus" schema - -modelLockStatus :: Doc.Model -modelLockStatus = - Doc.defineModel "LockStatus" $ do - Doc.property "lockStatus" typeLockStatusValue $ Doc.description "" - -typeLockStatusValue :: Doc.DataType -typeLockStatusValue = - Doc.string $ - Doc.enum - [ "locked", - "unlocked" - ] - -instance ToSchema LockStatusValue where - schema = - enum @Text "LockStatusValue" $ - mconcat - [ element "locked" Locked, - element "unlocked" Unlocked - ] - -instance ToByteString LockStatusValue where - builder Locked = "locked" - builder Unlocked = "unlocked" - -instance FromByteString LockStatusValue where - parser = - Parser.takeByteString >>= \b -> - case T.decodeUtf8' b of - Right "locked" -> pure Locked - Right "unlocked" -> pure Unlocked - Right t -> fail $ "Invalid LockStatusValue: " <> T.unpack t - Left e -> fail $ "Invalid LockStatusValue: " <> show e - -instance Cass.Cql LockStatusValue where - ctype = Cass.Tagged Cass.IntColumn - - fromCql (Cass.CqlInt n) = case n of - 0 -> pure Locked - 1 -> pure Unlocked - _ -> Left "fromCql: Invalid LockStatusValue" - fromCql _ = Left "fromCql: LockStatusValue: CqlInt expected" - - toCql Locked = Cass.CqlInt 0 - toCql Unlocked = Cass.CqlInt 1 ---------------------------------------------------------------------- -- internal diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generator.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generator.hs index e4daf3da24b..4d022f0eac0 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generator.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generator.hs @@ -328,8 +328,8 @@ generateTestModule = do generateBindingModule @Team.TeamDeleteData "team" ref generateBindingModule @Team.Conversation.TeamConversation "team" ref generateBindingModule @Team.Conversation.TeamConversationList "team" ref - generateBindingModule @(Team.Feature.TeamFeatureStatus 'Team.Feature.WithoutLockStatus 'Team.Feature.TeamFeatureLegalHold) "team" ref - generateBindingModule @(Team.Feature.TeamFeatureStatus 'Team.Feature.WithoutLockStatus 'Team.Feature.TeamFeatureAppLock) "team" ref + generateBindingModule @(Team.Feature.TeamFeatureStatus 'Team.Feature.TeamFeatureLegalHold) "team" ref + generateBindingModule @(Team.Feature.TeamFeatureStatus 'Team.Feature.TeamFeatureAppLock) "team" ref generateBindingModule @Team.Feature.TeamFeatureStatusValue "team" ref generateBindingModule @Team.Invitation.InvitationRequest "team" ref generateBindingModule @Team.Invitation.Invitation "team" ref diff --git a/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/Aeson.hs b/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/Aeson.hs index 05501016904..6e09181e543 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/Aeson.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/Aeson.hs @@ -195,21 +195,17 @@ tests = testRoundTrip @Team.TeamDeleteData, testRoundTrip @Team.Conversation.TeamConversation, testRoundTrip @Team.Conversation.TeamConversationList, - testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.WithoutLockStatus 'Team.Feature.TeamFeatureLegalHold), - testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.WithoutLockStatus 'Team.Feature.TeamFeatureSSO), - testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.WithoutLockStatus 'Team.Feature.TeamFeatureSearchVisibility), - testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.WithoutLockStatus 'Team.Feature.TeamFeatureValidateSAMLEmails), - testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.WithoutLockStatus 'Team.Feature.TeamFeatureDigitalSignatures), - testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.WithoutLockStatus 'Team.Feature.TeamFeatureAppLock), - testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.WithoutLockStatus 'Team.Feature.TeamFeatureFileSharing), - testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.WithoutLockStatus 'Team.Feature.TeamFeatureClassifiedDomains), - testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.WithoutLockStatus 'Team.Feature.TeamFeatureConferenceCalling), - testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.WithoutLockStatus 'Team.Feature.TeamFeatureSelfDeletingMessages), - testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.WithLockStatus 'Team.Feature.TeamFeatureSelfDeletingMessages), - testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.WithoutLockStatus 'Team.Feature.TeamFeatureSelfDeletingMessages), + testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.TeamFeatureLegalHold), + testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.TeamFeatureSSO), + testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.TeamFeatureSearchVisibility), + testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.TeamFeatureValidateSAMLEmails), + testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.TeamFeatureDigitalSignatures), + testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.TeamFeatureAppLock), + testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.TeamFeatureFileSharing), + testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.TeamFeatureClassifiedDomains), + testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.TeamFeatureConferenceCalling), + testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.TeamFeatureSelfDeletingMessages), testRoundTrip @Team.Feature.TeamFeatureStatusValue, - testRoundTrip @Team.Feature.LockStatusValue, - testRoundTrip @Team.Feature.LockStatus, testRoundTrip @Team.Invitation.InvitationRequest, testRoundTrip @Team.Invitation.Invitation, testRoundTrip @Team.Invitation.InvitationList, diff --git a/services/brig/src/Brig/IO/Intra.hs b/services/brig/src/Brig/IO/Intra.hs index 3a906829fea..df063cbdd0d 100644 --- a/services/brig/src/Brig/IO/Intra.hs +++ b/services/brig/src/Brig/IO/Intra.hs @@ -121,7 +121,7 @@ import Wire.API.Federation.API.Brig import Wire.API.Federation.Client import Wire.API.Federation.Error (federationNotImplemented) import Wire.API.Message (UserClients) -import Wire.API.Team.Feature (IncludeLockStatus (..), TeamFeatureName (..), TeamFeatureStatus) +import Wire.API.Team.Feature (TeamFeatureName (..), TeamFeatureStatus) import Wire.API.Team.LegalHold (LegalholdProtectee) ----------------------------------------------------------------------------- @@ -968,7 +968,7 @@ getTeamName tid = do . expect2xx -- | Calls 'Galley.API.getTeamFeatureStatusH'. -getTeamLegalHoldStatus :: TeamId -> AppIO (TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureLegalHold) +getTeamLegalHoldStatus :: TeamId -> AppIO (TeamFeatureStatus 'TeamFeatureLegalHold) getTeamLegalHoldStatus tid = do debug $ remote "galley" . msg (val "Get legalhold settings") galleyRequest GET req >>= decodeBody "galley" diff --git a/services/brig/src/Brig/Options.hs b/services/brig/src/Brig/Options.hs index 874fd3a4a1c..7710b7608ef 100644 --- a/services/brig/src/Brig/Options.hs +++ b/services/brig/src/Brig/Options.hs @@ -508,8 +508,8 @@ data Settings = Settings -- they are grandfathered), and feature-specific extra data (eg., TLL for self-deleting -- messages). For now, we have something quick & simple. data AccountFeatureConfigs = AccountFeatureConfigs - { afcConferenceCallingDefNew :: !(ApiFT.TeamFeatureStatus 'ApiFT.WithoutLockStatus 'ApiFT.TeamFeatureConferenceCalling), - afcConferenceCallingDefNull :: !(ApiFT.TeamFeatureStatus 'ApiFT.WithoutLockStatus 'ApiFT.TeamFeatureConferenceCalling) + { afcConferenceCallingDefNew :: !(ApiFT.TeamFeatureStatus 'ApiFT.TeamFeatureConferenceCalling), + afcConferenceCallingDefNull :: !(ApiFT.TeamFeatureStatus 'ApiFT.TeamFeatureConferenceCalling) } deriving (Show, Eq, Generic) deriving (Arbitrary) via (GenericUniform AccountFeatureConfigs) diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index d6247bd175b..b1f68193ca3 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -437,7 +437,6 @@ executable galley-schema V52_FeatureConferenceCalling V53_AddRemoteConvStatus V54_TeamFeatureSelfDeletingMessages - V55_SelfDeletingMessagesLockStatus Paths_galley hs-source-dirs: schema/src diff --git a/services/galley/schema/src/Main.hs b/services/galley/schema/src/Main.hs index e6bed347169..369a4644368 100644 --- a/services/galley/schema/src/Main.hs +++ b/services/galley/schema/src/Main.hs @@ -57,7 +57,6 @@ import qualified V51_FeatureFileSharing import qualified V52_FeatureConferenceCalling import qualified V53_AddRemoteConvStatus import qualified V54_TeamFeatureSelfDeletingMessages -import qualified V55_SelfDeletingMessagesLockStatus main :: IO () main = do @@ -100,10 +99,9 @@ main = do V51_FeatureFileSharing.migration, V52_FeatureConferenceCalling.migration, V53_AddRemoteConvStatus.migration, - V54_TeamFeatureSelfDeletingMessages.migration, - V55_SelfDeletingMessagesLockStatus.migration + V54_TeamFeatureSelfDeletingMessages.migration -- When adding migrations here, don't forget to update - -- 'schemaVersion' in Galley.Cassandra + -- 'schemaVersion' in Galley.Data -- (see also docs/developer/cassandra-interaction.md) -- -- FUTUREWORK: once #1726 has made its way to master/production, diff --git a/services/galley/schema/src/V55_SelfDeletingMessagesLockStatus.hs b/services/galley/schema/src/V55_SelfDeletingMessagesLockStatus.hs deleted file mode 100644 index 58e61690693..00000000000 --- a/services/galley/schema/src/V55_SelfDeletingMessagesLockStatus.hs +++ /dev/null @@ -1,33 +0,0 @@ --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2020 Wire Swiss GmbH --- --- 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 . - -module V55_SelfDeletingMessagesLockStatus - ( migration, - ) -where - -import Cassandra.Schema -import Imports -import Text.RawString.QQ - -migration :: Migration -migration = Migration 55 "Add payment status config for self deleting messages team feature" $ do - schema' - [r| ALTER TABLE team_features ADD ( - self_deleting_messages_lock_status int - ) - |] diff --git a/services/galley/src/Galley/API/Error.hs b/services/galley/src/Galley/API/Error.hs index 2f49164b8ba..34c6ec0d3c8 100644 --- a/services/galley/src/Galley/API/Error.hs +++ b/services/galley/src/Galley/API/Error.hs @@ -161,14 +161,12 @@ data TeamFeatureError | LegalHoldFeatureFlagNotEnabled | LegalHoldWhitelistedOnly | DisableSsoNotImplemented - | FeatureLocked instance APIError TeamFeatureError where toWai AppLockinactivityTimeoutTooLow = inactivityTimeoutTooLow toWai LegalHoldFeatureFlagNotEnabled = legalHoldFeatureFlagNotEnabled toWai LegalHoldWhitelistedOnly = legalHoldWhitelistedOnly toWai DisableSsoNotImplemented = disableSsoNotImplemented - toWai FeatureLocked = setTeamFeatureConfigFeatureLocked data TeamNotificationError = InvalidTeamNotificationId @@ -460,9 +458,6 @@ noLegalHoldDeviceAllocated = mkError status404 "legalhold-no-device-allocated" " legalHoldCouldNotBlockConnections :: Error legalHoldCouldNotBlockConnections = mkError status500 "legalhold-internal" "legal hold service: could not block connections when resolving policy conflicts." -setTeamFeatureConfigFeatureLocked :: Error -setTeamFeatureConfigFeatureLocked = mkError status409 "feature-locked" "feature config cannot be updated (eg., because it is configured to be locked, or because you need to upgrade your plan)" - disableSsoNotImplemented :: Error disableSsoNotImplemented = mkError diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index 5d870c0dddb..5c5a555b927 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -52,7 +52,6 @@ import Galley.API.Util import Galley.App import Galley.Cassandra.Paging import qualified Galley.Data.Conversation as Data -import Galley.Data.TeamFeatures (MaybeHasLockStatusCol) import Galley.Effects import Galley.Effects.ClientStore import Galley.Effects.ConversationStore @@ -122,82 +121,79 @@ data InternalApi routes = InternalApi -- Viewing the config for features should be allowed for any admin. iTeamFeatureStatusSSOGet :: routes - :- IFeatureStatusGet 'Public.WithoutLockStatus 'Public.TeamFeatureSSO, + :- IFeatureStatusGet 'Public.TeamFeatureSSO, iTeamFeatureStatusSSOPut :: routes :- IFeatureStatusPut 'Public.TeamFeatureSSO, iTeamFeatureStatusLegalHoldGet :: routes - :- IFeatureStatusGet 'Public.WithoutLockStatus 'Public.TeamFeatureLegalHold, + :- IFeatureStatusGet 'Public.TeamFeatureLegalHold, iTeamFeatureStatusLegalHoldPut :: routes :- IFeatureStatusPut 'Public.TeamFeatureLegalHold, iTeamFeatureStatusSearchVisibilityGet :: routes - :- IFeatureStatusGet 'Public.WithoutLockStatus 'Public.TeamFeatureSearchVisibility, + :- IFeatureStatusGet 'Public.TeamFeatureSearchVisibility, iTeamFeatureStatusSearchVisibilityPut :: routes :- IFeatureStatusPut 'Public.TeamFeatureSearchVisibility, iTeamFeatureStatusSearchVisibilityDeprecatedGet :: routes - :- IFeatureStatusDeprecatedGet 'Public.WithoutLockStatus 'Public.TeamFeatureSearchVisibility, + :- IFeatureStatusDeprecatedGet 'Public.TeamFeatureSearchVisibility, iTeamFeatureStatusSearchVisibilityDeprecatedPut :: routes :- IFeatureStatusDeprecatedPut 'Public.TeamFeatureSearchVisibility, iTeamFeatureStatusValidateSAMLEmailsGet :: routes - :- IFeatureStatusGet 'Public.WithoutLockStatus 'Public.TeamFeatureValidateSAMLEmails, + :- IFeatureStatusGet 'Public.TeamFeatureValidateSAMLEmails, iTeamFeatureStatusValidateSAMLEmailsPut :: routes :- IFeatureStatusPut 'Public.TeamFeatureValidateSAMLEmails, iTeamFeatureStatusValidateSAMLEmailsDeprecatedGet :: routes - :- IFeatureStatusDeprecatedGet 'Public.WithoutLockStatus 'Public.TeamFeatureValidateSAMLEmails, + :- IFeatureStatusDeprecatedGet 'Public.TeamFeatureValidateSAMLEmails, iTeamFeatureStatusValidateSAMLEmailsDeprecatedPut :: routes :- IFeatureStatusDeprecatedPut 'Public.TeamFeatureValidateSAMLEmails, iTeamFeatureStatusDigitalSignaturesGet :: routes - :- IFeatureStatusGet 'Public.WithoutLockStatus 'Public.TeamFeatureDigitalSignatures, + :- IFeatureStatusGet 'Public.TeamFeatureDigitalSignatures, iTeamFeatureStatusDigitalSignaturesPut :: routes :- IFeatureStatusPut 'Public.TeamFeatureDigitalSignatures, iTeamFeatureStatusDigitalSignaturesDeprecatedGet :: routes - :- IFeatureStatusDeprecatedGet 'Public.WithoutLockStatus 'Public.TeamFeatureDigitalSignatures, + :- IFeatureStatusDeprecatedGet 'Public.TeamFeatureDigitalSignatures, iTeamFeatureStatusDigitalSignaturesDeprecatedPut :: routes :- IFeatureStatusDeprecatedPut 'Public.TeamFeatureDigitalSignatures, iTeamFeatureStatusAppLockGet :: routes - :- IFeatureStatusGet 'Public.WithoutLockStatus 'Public.TeamFeatureAppLock, + :- IFeatureStatusGet 'Public.TeamFeatureAppLock, iTeamFeatureStatusAppLockPut :: routes :- IFeatureStatusPut 'Public.TeamFeatureAppLock, iTeamFeatureStatusFileSharingGet :: routes - :- IFeatureStatusGet 'Public.WithoutLockStatus 'Public.TeamFeatureFileSharing, + :- IFeatureStatusGet 'Public.TeamFeatureFileSharing, iTeamFeatureStatusFileSharingPut :: routes :- IFeatureStatusPut 'Public.TeamFeatureFileSharing, iTeamFeatureStatusClassifiedDomainsGet :: routes - :- IFeatureStatusGet 'Public.WithoutLockStatus 'Public.TeamFeatureClassifiedDomains, + :- IFeatureStatusGet 'Public.TeamFeatureClassifiedDomains, iTeamFeatureStatusConferenceCallingPut :: routes :- IFeatureStatusPut 'Public.TeamFeatureConferenceCalling, iTeamFeatureStatusConferenceCallingGet :: routes - :- IFeatureStatusGet 'Public.WithoutLockStatus 'Public.TeamFeatureConferenceCalling, + :- IFeatureStatusGet 'Public.TeamFeatureConferenceCalling, iTeamFeatureStatusSelfDeletingMessagesPut :: routes :- IFeatureStatusPut 'Public.TeamFeatureSelfDeletingMessages, iTeamFeatureStatusSelfDeletingMessagesGet :: routes - :- IFeatureStatusGet 'Public.WithLockStatus 'Public.TeamFeatureSelfDeletingMessages, - iTeamFeatureLockStatusSelfDeletingMessagesPut :: - routes - :- IFeatureStatusLockStatusPut 'Public.TeamFeatureSelfDeletingMessages, + :- IFeatureStatusGet 'Public.TeamFeatureSelfDeletingMessages, -- This endpoint can lead to the following events being sent: -- - MemberLeave event to members for all conversations the user was in iDeleteUser :: @@ -236,14 +232,14 @@ data InternalApi routes = InternalApi type ServantAPI = ToServantApi InternalApi -type IFeatureStatusGet lockStatus featureName = +type IFeatureStatusGet featureName = Summary (AppendSymbol "Get config for " (Public.KnownTeamFeatureNameSymbol featureName)) :> "i" :> "teams" :> Capture "tid" TeamId :> "features" :> Public.KnownTeamFeatureNameSymbol featureName - :> Get '[Servant.JSON] (Public.TeamFeatureStatus lockStatus featureName) + :> Get '[Servant.JSON] (Public.TeamFeatureStatus featureName) type IFeatureStatusPut featureName = Summary (AppendSymbol "Put config for " (Public.KnownTeamFeatureNameSymbol featureName)) @@ -252,28 +248,18 @@ type IFeatureStatusPut featureName = :> Capture "tid" TeamId :> "features" :> Public.KnownTeamFeatureNameSymbol featureName - :> ReqBody '[Servant.JSON] (Public.TeamFeatureStatus 'Public.WithoutLockStatus featureName) - :> Put '[Servant.JSON] (Public.TeamFeatureStatus 'Public.WithoutLockStatus featureName) - -type IFeatureStatusLockStatusPut featureName = - Summary (AppendSymbol "(Un-)lock " (Public.KnownTeamFeatureNameSymbol featureName)) - :> "i" - :> "teams" - :> Capture "tid" TeamId - :> "features" - :> Public.KnownTeamFeatureNameSymbol featureName - :> Capture "lockStatus" Public.LockStatusValue - :> Put '[Servant.JSON] Public.LockStatus + :> ReqBody '[Servant.JSON] (Public.TeamFeatureStatus featureName) + :> Put '[Servant.JSON] (Public.TeamFeatureStatus featureName) -- | A type for a GET endpoint for a feature with a deprecated path -type IFeatureStatusDeprecatedGet lockStatus featureName = +type IFeatureStatusDeprecatedGet featureName = Summary (AppendSymbol "[deprecated] Get config for " (Public.KnownTeamFeatureNameSymbol featureName)) :> "i" :> "teams" :> Capture "tid" TeamId :> "features" :> Public.DeprecatedFeatureName featureName - :> Get '[Servant.JSON] (Public.TeamFeatureStatus lockStatus featureName) + :> Get '[Servant.JSON] (Public.TeamFeatureStatus featureName) -- | A type for a PUT endpoint for a feature with a deprecated path type IFeatureStatusDeprecatedPut featureName = @@ -283,8 +269,8 @@ type IFeatureStatusDeprecatedPut featureName = :> Capture "tid" TeamId :> "features" :> Public.DeprecatedFeatureName featureName - :> ReqBody '[Servant.JSON] (Public.TeamFeatureStatus 'Public.WithoutLockStatus featureName) - :> Put '[Servant.JSON] (Public.TeamFeatureStatus 'Public.WithoutLockStatus featureName) + :> ReqBody '[Servant.JSON] (Public.TeamFeatureStatus featureName) + :> Put '[Servant.JSON] (Public.TeamFeatureStatus featureName) servantSitemap :: ServerT ServantAPI (Sem GalleyEffects) servantSitemap = @@ -292,39 +278,38 @@ servantSitemap = InternalApi { iStatusGet = pure NoContent, iStatusHead = pure NoContent, - iTeamFeatureStatusSSOGet = iGetTeamFeature @'Public.WithoutLockStatus @'Public.TeamFeatureSSO Features.getSSOStatusInternal, + iTeamFeatureStatusSSOGet = iGetTeamFeature @'Public.TeamFeatureSSO Features.getSSOStatusInternal, iTeamFeatureStatusSSOPut = iPutTeamFeature @'Public.TeamFeatureSSO Features.setSSOStatusInternal, - iTeamFeatureStatusLegalHoldGet = iGetTeamFeature @'Public.WithoutLockStatus @'Public.TeamFeatureLegalHold Features.getLegalholdStatusInternal, + iTeamFeatureStatusLegalHoldGet = iGetTeamFeature @'Public.TeamFeatureLegalHold Features.getLegalholdStatusInternal, iTeamFeatureStatusLegalHoldPut = iPutTeamFeature @'Public.TeamFeatureLegalHold (Features.setLegalholdStatusInternal @InternalPaging), - iTeamFeatureStatusSearchVisibilityGet = iGetTeamFeature @'Public.WithoutLockStatus @'Public.TeamFeatureSearchVisibility Features.getTeamSearchVisibilityAvailableInternal, + iTeamFeatureStatusSearchVisibilityGet = iGetTeamFeature @'Public.TeamFeatureSearchVisibility Features.getTeamSearchVisibilityAvailableInternal, iTeamFeatureStatusSearchVisibilityPut = iPutTeamFeature @'Public.TeamFeatureLegalHold Features.setTeamSearchVisibilityAvailableInternal, - iTeamFeatureStatusSearchVisibilityDeprecatedGet = iGetTeamFeature @'Public.WithoutLockStatus @'Public.TeamFeatureSearchVisibility Features.getTeamSearchVisibilityAvailableInternal, + iTeamFeatureStatusSearchVisibilityDeprecatedGet = iGetTeamFeature @'Public.TeamFeatureSearchVisibility Features.getTeamSearchVisibilityAvailableInternal, iTeamFeatureStatusSearchVisibilityDeprecatedPut = iPutTeamFeature @'Public.TeamFeatureLegalHold Features.setTeamSearchVisibilityAvailableInternal, - iTeamFeatureStatusValidateSAMLEmailsGet = iGetTeamFeature @'Public.WithoutLockStatus @'Public.TeamFeatureValidateSAMLEmails Features.getValidateSAMLEmailsInternal, + iTeamFeatureStatusValidateSAMLEmailsGet = iGetTeamFeature @'Public.TeamFeatureValidateSAMLEmails Features.getValidateSAMLEmailsInternal, iTeamFeatureStatusValidateSAMLEmailsPut = iPutTeamFeature @'Public.TeamFeatureValidateSAMLEmails Features.setValidateSAMLEmailsInternal, - iTeamFeatureStatusValidateSAMLEmailsDeprecatedGet = iGetTeamFeature @'Public.WithoutLockStatus @'Public.TeamFeatureValidateSAMLEmails Features.getValidateSAMLEmailsInternal, + iTeamFeatureStatusValidateSAMLEmailsDeprecatedGet = iGetTeamFeature @'Public.TeamFeatureValidateSAMLEmails Features.getValidateSAMLEmailsInternal, iTeamFeatureStatusValidateSAMLEmailsDeprecatedPut = iPutTeamFeature @'Public.TeamFeatureValidateSAMLEmails Features.setValidateSAMLEmailsInternal, - iTeamFeatureStatusDigitalSignaturesGet = iGetTeamFeature @'Public.WithoutLockStatus @'Public.TeamFeatureDigitalSignatures Features.getDigitalSignaturesInternal, + iTeamFeatureStatusDigitalSignaturesGet = iGetTeamFeature @'Public.TeamFeatureDigitalSignatures Features.getDigitalSignaturesInternal, iTeamFeatureStatusDigitalSignaturesPut = iPutTeamFeature @'Public.TeamFeatureDigitalSignatures Features.setDigitalSignaturesInternal, - iTeamFeatureStatusDigitalSignaturesDeprecatedGet = iGetTeamFeature @'Public.WithoutLockStatus @'Public.TeamFeatureDigitalSignatures Features.getDigitalSignaturesInternal, + iTeamFeatureStatusDigitalSignaturesDeprecatedGet = iGetTeamFeature @'Public.TeamFeatureDigitalSignatures Features.getDigitalSignaturesInternal, iTeamFeatureStatusDigitalSignaturesDeprecatedPut = iPutTeamFeature @'Public.TeamFeatureDigitalSignatures Features.setDigitalSignaturesInternal, - iTeamFeatureStatusAppLockGet = iGetTeamFeature @'Public.WithoutLockStatus @'Public.TeamFeatureAppLock Features.getAppLockInternal, + iTeamFeatureStatusAppLockGet = iGetTeamFeature @'Public.TeamFeatureAppLock Features.getAppLockInternal, iTeamFeatureStatusAppLockPut = iPutTeamFeature @'Public.TeamFeatureAppLock Features.setAppLockInternal, - iTeamFeatureStatusFileSharingGet = iGetTeamFeature @'Public.WithoutLockStatus @'Public.TeamFeatureFileSharing Features.getFileSharingInternal, + iTeamFeatureStatusFileSharingGet = iGetTeamFeature @'Public.TeamFeatureFileSharing Features.getFileSharingInternal, iTeamFeatureStatusFileSharingPut = iPutTeamFeature @'Public.TeamFeatureFileSharing Features.setFileSharingInternal, - iTeamFeatureStatusClassifiedDomainsGet = iGetTeamFeature @'Public.WithoutLockStatus @'Public.TeamFeatureClassifiedDomains Features.getClassifiedDomainsInternal, + iTeamFeatureStatusClassifiedDomainsGet = iGetTeamFeature @'Public.TeamFeatureClassifiedDomains Features.getClassifiedDomainsInternal, iTeamFeatureStatusConferenceCallingPut = iPutTeamFeature @'Public.TeamFeatureConferenceCalling Features.setConferenceCallingInternal, - iTeamFeatureStatusConferenceCallingGet = iGetTeamFeature @'Public.WithoutLockStatus @'Public.TeamFeatureConferenceCalling Features.getConferenceCallingInternal, + iTeamFeatureStatusConferenceCallingGet = iGetTeamFeature @'Public.TeamFeatureConferenceCalling Features.getConferenceCallingInternal, iTeamFeatureStatusSelfDeletingMessagesPut = iPutTeamFeature @'Public.TeamFeatureSelfDeletingMessages Features.setSelfDeletingMessagesInternal, - iTeamFeatureStatusSelfDeletingMessagesGet = iGetTeamFeature @'Public.WithLockStatus @'Public.TeamFeatureSelfDeletingMessages Features.getSelfDeletingMessagesInternal, - iTeamFeatureLockStatusSelfDeletingMessagesPut = Features.setLockStatus @'Public.TeamFeatureSelfDeletingMessages, + iTeamFeatureStatusSelfDeletingMessagesGet = iGetTeamFeature @'Public.TeamFeatureSelfDeletingMessages Features.getSelfDeletingMessagesInternal, iDeleteUser = rmUser, iConnect = Create.createConnectConversation, iUpsertOne2OneConversation = One2One.iUpsertOne2OneConversation } iGetTeamFeature :: - forall ps a r. + forall a r. ( Public.KnownTeamFeatureName a, Members '[ Error ActionError, @@ -334,29 +319,26 @@ iGetTeamFeature :: ] r ) => - (Features.GetFeatureInternalParam -> Sem r (Public.TeamFeatureStatus ps a)) -> + (Features.GetFeatureInternalParam -> Sem r (Public.TeamFeatureStatus a)) -> TeamId -> - Sem r (Public.TeamFeatureStatus ps a) -iGetTeamFeature getter = Features.getFeatureStatus @ps @a getter DontDoAuth + Sem r (Public.TeamFeatureStatus a) +iGetTeamFeature getter = Features.getFeatureStatus @a getter DontDoAuth iPutTeamFeature :: forall a r. ( Public.KnownTeamFeatureName a, - MaybeHasLockStatusCol a, Members '[ Error ActionError, Error NotATeamMember, Error TeamError, - Error TeamFeatureError, - TeamStore, - TeamFeatureStore + TeamStore ] r ) => - (TeamId -> Public.TeamFeatureStatus 'Public.WithoutLockStatus a -> Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus a)) -> + (TeamId -> Public.TeamFeatureStatus a -> Sem r (Public.TeamFeatureStatus a)) -> TeamId -> - Public.TeamFeatureStatus 'Public.WithoutLockStatus a -> - Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus a) + Public.TeamFeatureStatus a -> + Sem r (Public.TeamFeatureStatus a) iPutTeamFeature setter = Features.setFeatureStatus @a setter DontDoAuth sitemap :: Routes a (Sem GalleyEffects) () @@ -599,7 +581,7 @@ rmUser lusr conn = do for_ (maybeList1 (catMaybes pp)) - push + (push) -- FUTUREWORK: This could be optimized to reduce the number of RPCs -- made. When a team is deleted the burst of RPCs created here could diff --git a/services/galley/src/Galley/API/LegalHold.hs b/services/galley/src/Galley/API/LegalHold.hs index 051d82c30a2..5bbe62a2362 100644 --- a/services/galley/src/Galley/API/LegalHold.hs +++ b/services/galley/src/Galley/API/LegalHold.hs @@ -103,7 +103,7 @@ isLegalHoldEnabledForTeam tid = do pure False FeatureLegalHoldDisabledByDefault -> do statusValue <- - Public.tfwoStatus <$$> TeamFeatures.getFeatureStatusNoConfig @'Public.WithoutLockStatus @'Public.TeamFeatureLegalHold tid + Public.tfwoStatus <$$> TeamFeatures.getFeatureStatusNoConfig @'Public.TeamFeatureLegalHold tid return $ case statusValue of Just Public.TeamFeatureEnabled -> True Just Public.TeamFeatureDisabled -> False diff --git a/services/galley/src/Galley/API/Public.hs b/services/galley/src/Galley/API/Public.hs index fa6eb5e7a56..3027ba070ab 100644 --- a/services/galley/src/Galley/API/Public.hs +++ b/services/galley/src/Galley/API/Public.hs @@ -117,70 +117,70 @@ servantSitemap = GalleyAPI.postOtrMessageUnqualified = Update.postOtrMessageUnqualified, GalleyAPI.postProteusMessage = Update.postProteusMessage, GalleyAPI.teamFeatureStatusSSOGet = - getFeatureStatus @'Public.WithoutLockStatus @'Public.TeamFeatureSSO Features.getSSOStatusInternal + getFeatureStatus @'Public.TeamFeatureSSO Features.getSSOStatusInternal . DoAuth, GalleyAPI.teamFeatureStatusLegalHoldGet = - getFeatureStatus @'Public.WithoutLockStatus @'Public.TeamFeatureLegalHold Features.getLegalholdStatusInternal + getFeatureStatus @'Public.TeamFeatureLegalHold Features.getLegalholdStatusInternal . DoAuth, GalleyAPI.teamFeatureStatusLegalHoldPut = setFeatureStatus @'Public.TeamFeatureLegalHold (Features.setLegalholdStatusInternal @InternalPaging) . DoAuth, GalleyAPI.teamFeatureStatusSearchVisibilityGet = - getFeatureStatus @'Public.WithoutLockStatus @'Public.TeamFeatureSearchVisibility Features.getTeamSearchVisibilityAvailableInternal + getFeatureStatus @'Public.TeamFeatureSearchVisibility Features.getTeamSearchVisibilityAvailableInternal . DoAuth, GalleyAPI.teamFeatureStatusSearchVisibilityPut = setFeatureStatus @'Public.TeamFeatureSearchVisibility Features.setTeamSearchVisibilityAvailableInternal . DoAuth, GalleyAPI.teamFeatureStatusSearchVisibilityDeprecatedGet = - getFeatureStatus @'Public.WithoutLockStatus @'Public.TeamFeatureSearchVisibility Features.getTeamSearchVisibilityAvailableInternal + getFeatureStatus @'Public.TeamFeatureSearchVisibility Features.getTeamSearchVisibilityAvailableInternal . DoAuth, GalleyAPI.teamFeatureStatusSearchVisibilityDeprecatedPut = setFeatureStatus @'Public.TeamFeatureSearchVisibility Features.setTeamSearchVisibilityAvailableInternal . DoAuth, GalleyAPI.teamFeatureStatusValidateSAMLEmailsGet = - getFeatureStatus @'Public.WithoutLockStatus @'Public.TeamFeatureValidateSAMLEmails Features.getValidateSAMLEmailsInternal + getFeatureStatus @'Public.TeamFeatureValidateSAMLEmails Features.getValidateSAMLEmailsInternal . DoAuth, GalleyAPI.teamFeatureStatusValidateSAMLEmailsDeprecatedGet = - getFeatureStatus @'Public.WithoutLockStatus @'Public.TeamFeatureValidateSAMLEmails Features.getValidateSAMLEmailsInternal + getFeatureStatus @'Public.TeamFeatureValidateSAMLEmails Features.getValidateSAMLEmailsInternal . DoAuth, GalleyAPI.teamFeatureStatusDigitalSignaturesGet = - getFeatureStatus @'Public.WithoutLockStatus @'Public.TeamFeatureDigitalSignatures Features.getDigitalSignaturesInternal + getFeatureStatus @'Public.TeamFeatureDigitalSignatures Features.getDigitalSignaturesInternal . DoAuth, GalleyAPI.teamFeatureStatusDigitalSignaturesDeprecatedGet = - getFeatureStatus @'Public.WithoutLockStatus @'Public.TeamFeatureDigitalSignatures Features.getDigitalSignaturesInternal + getFeatureStatus @'Public.TeamFeatureDigitalSignatures Features.getDigitalSignaturesInternal . DoAuth, GalleyAPI.teamFeatureStatusAppLockGet = - getFeatureStatus @'Public.WithoutLockStatus @'Public.TeamFeatureAppLock Features.getAppLockInternal + getFeatureStatus @'Public.TeamFeatureAppLock Features.getAppLockInternal . DoAuth, GalleyAPI.teamFeatureStatusAppLockPut = setFeatureStatus @'Public.TeamFeatureAppLock Features.setAppLockInternal . DoAuth, GalleyAPI.teamFeatureStatusFileSharingGet = - getFeatureStatus @'Public.WithoutLockStatus @'Public.TeamFeatureFileSharing Features.getFileSharingInternal . DoAuth, + getFeatureStatus @'Public.TeamFeatureFileSharing Features.getFileSharingInternal . DoAuth, GalleyAPI.teamFeatureStatusFileSharingPut = setFeatureStatus @'Public.TeamFeatureFileSharing Features.setFileSharingInternal . DoAuth, GalleyAPI.teamFeatureStatusClassifiedDomainsGet = - getFeatureStatus @'Public.WithoutLockStatus @'Public.TeamFeatureClassifiedDomains Features.getClassifiedDomainsInternal + getFeatureStatus @'Public.TeamFeatureClassifiedDomains Features.getClassifiedDomainsInternal . DoAuth, GalleyAPI.teamFeatureStatusConferenceCallingGet = - getFeatureStatus @'Public.WithoutLockStatus @'Public.TeamFeatureConferenceCalling Features.getConferenceCallingInternal + getFeatureStatus @'Public.TeamFeatureConferenceCalling Features.getConferenceCallingInternal . DoAuth, GalleyAPI.teamFeatureStatusSelfDeletingMessagesGet = - getFeatureStatus @'Public.WithLockStatus @'Public.TeamFeatureSelfDeletingMessages Features.getSelfDeletingMessagesInternal + getFeatureStatus @'Public.TeamFeatureSelfDeletingMessages Features.getSelfDeletingMessagesInternal . DoAuth, GalleyAPI.teamFeatureStatusSelfDeletingMessagesPut = setFeatureStatus @'Public.TeamFeatureSelfDeletingMessages Features.setSelfDeletingMessagesInternal . DoAuth, GalleyAPI.featureAllFeatureConfigsGet = Features.getAllFeatureConfigs, - GalleyAPI.featureConfigLegalHoldGet = Features.getFeatureConfig @'Public.WithoutLockStatus @'Public.TeamFeatureLegalHold Features.getLegalholdStatusInternal, - GalleyAPI.featureConfigSSOGet = Features.getFeatureConfig @'Public.WithoutLockStatus @'Public.TeamFeatureSSO Features.getSSOStatusInternal, - GalleyAPI.featureConfigSearchVisibilityGet = Features.getFeatureConfig @'Public.WithoutLockStatus @'Public.TeamFeatureSearchVisibility Features.getTeamSearchVisibilityAvailableInternal, - GalleyAPI.featureConfigValidateSAMLEmailsGet = Features.getFeatureConfig @'Public.WithoutLockStatus @'Public.TeamFeatureValidateSAMLEmails Features.getValidateSAMLEmailsInternal, - GalleyAPI.featureConfigDigitalSignaturesGet = Features.getFeatureConfig @'Public.WithoutLockStatus @'Public.TeamFeatureDigitalSignatures Features.getDigitalSignaturesInternal, - GalleyAPI.featureConfigAppLockGet = Features.getFeatureConfig @'Public.WithoutLockStatus @'Public.TeamFeatureAppLock Features.getAppLockInternal, - GalleyAPI.featureConfigFileSharingGet = Features.getFeatureConfig @'Public.WithoutLockStatus @'Public.TeamFeatureFileSharing Features.getFileSharingInternal, - GalleyAPI.featureConfigClassifiedDomainsGet = Features.getFeatureConfig @'Public.WithoutLockStatus @'Public.TeamFeatureClassifiedDomains Features.getClassifiedDomainsInternal, - GalleyAPI.featureConfigConferenceCallingGet = Features.getFeatureConfig @'Public.WithoutLockStatus @'Public.TeamFeatureConferenceCalling Features.getConferenceCallingInternal, - GalleyAPI.featureConfigSelfDeletingMessagesGet = Features.getFeatureConfig @'Public.WithLockStatus @'Public.TeamFeatureSelfDeletingMessages Features.getSelfDeletingMessagesInternal + GalleyAPI.featureConfigLegalHoldGet = Features.getFeatureConfig @'Public.TeamFeatureLegalHold Features.getLegalholdStatusInternal, + GalleyAPI.featureConfigSSOGet = Features.getFeatureConfig @'Public.TeamFeatureSSO Features.getSSOStatusInternal, + GalleyAPI.featureConfigSearchVisibilityGet = Features.getFeatureConfig @'Public.TeamFeatureSearchVisibility Features.getTeamSearchVisibilityAvailableInternal, + GalleyAPI.featureConfigValidateSAMLEmailsGet = Features.getFeatureConfig @'Public.TeamFeatureValidateSAMLEmails Features.getValidateSAMLEmailsInternal, + GalleyAPI.featureConfigDigitalSignaturesGet = Features.getFeatureConfig @'Public.TeamFeatureDigitalSignatures Features.getDigitalSignaturesInternal, + GalleyAPI.featureConfigAppLockGet = Features.getFeatureConfig @'Public.TeamFeatureAppLock Features.getAppLockInternal, + GalleyAPI.featureConfigFileSharingGet = Features.getFeatureConfig @'Public.TeamFeatureFileSharing Features.getFileSharingInternal, + GalleyAPI.featureConfigClassifiedDomainsGet = Features.getFeatureConfig @'Public.TeamFeatureClassifiedDomains Features.getClassifiedDomainsInternal, + GalleyAPI.featureConfigConferenceCallingGet = Features.getFeatureConfig @'Public.TeamFeatureConferenceCalling Features.getConferenceCallingInternal, + GalleyAPI.featureConfigSelfDeletingMessagesGet = Features.getFeatureConfig @'Public.TeamFeatureSelfDeletingMessages Features.getSelfDeletingMessagesInternal } sitemap :: Routes ApiBuilder (Sem GalleyEffects) () diff --git a/services/galley/src/Galley/API/Teams.hs b/services/galley/src/Galley/API/Teams.hs index 5f06956348c..ce9b1ef65ba 100644 --- a/services/galley/src/Galley/API/Teams.hs +++ b/services/galley/src/Galley/API/Teams.hs @@ -1522,7 +1522,7 @@ canUserJoinTeam tid = do getTeamSearchVisibilityAvailableInternal :: Members '[Input Opts, TeamFeatureStore] r => TeamId -> - Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureSearchVisibility) + Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureSearchVisibility) getTeamSearchVisibilityAvailableInternal tid = do -- TODO: This is just redundant given there is a decent default defConfig <- do @@ -1532,7 +1532,7 @@ getTeamSearchVisibilityAvailableInternal tid = do FeatureTeamSearchVisibilityDisabledByDefault -> Public.TeamFeatureDisabled fromMaybe defConfig - <$> TeamFeatures.getFeatureStatusNoConfig @'Public.WithoutLockStatus @'Public.TeamFeatureSearchVisibility tid + <$> TeamFeatures.getFeatureStatusNoConfig @'Public.TeamFeatureSearchVisibility tid -- | Modify and get visibility type for a team (internal, no user permission checks) getSearchVisibilityInternalH :: diff --git a/services/galley/src/Galley/API/Teams/Features.hs b/services/galley/src/Galley/API/Teams/Features.hs index 9c1650a29bb..19e49f76b1b 100644 --- a/services/galley/src/Galley/API/Teams/Features.hs +++ b/services/galley/src/Galley/API/Teams/Features.hs @@ -40,7 +40,6 @@ module Galley.API.Teams.Features setConferenceCallingInternal, getSelfDeletingMessagesInternal, setSelfDeletingMessagesInternal, - setLockStatus, DoAuth (..), GetFeatureInternalParam, ) @@ -91,7 +90,7 @@ data DoAuth = DoAuth UserId | DontDoAuth -- | For team-settings, to administrate team feature configuration. Here we have an admin uid -- and a team id, but no uid of the member for which the feature config holds. getFeatureStatus :: - forall (ps :: Public.IncludeLockStatus) (a :: Public.TeamFeatureName) r. + forall (a :: Public.TeamFeatureName) r. ( Public.KnownTeamFeatureName a, Members '[ Error ActionError, @@ -101,10 +100,10 @@ getFeatureStatus :: ] r ) => - (GetFeatureInternalParam -> Sem r (Public.TeamFeatureStatus ps a)) -> + (GetFeatureInternalParam -> Sem r (Public.TeamFeatureStatus a)) -> DoAuth -> TeamId -> - Sem r (Public.TeamFeatureStatus ps a) + Sem r (Public.TeamFeatureStatus a) getFeatureStatus getter doauth tid = do case doauth of DoAuth uid -> do @@ -118,21 +117,19 @@ getFeatureStatus getter doauth tid = do setFeatureStatus :: forall (a :: Public.TeamFeatureName) r. ( Public.KnownTeamFeatureName a, - MaybeHasLockStatusCol a, Members '[ Error ActionError, Error TeamError, Error NotATeamMember, - TeamStore, - TeamFeatureStore + TeamStore ] r ) => - (TeamId -> Public.TeamFeatureStatus 'Public.WithoutLockStatus a -> Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus a)) -> + (TeamId -> Public.TeamFeatureStatus a -> Sem r (Public.TeamFeatureStatus a)) -> DoAuth -> TeamId -> - Public.TeamFeatureStatus 'Public.WithoutLockStatus a -> - Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus a) + Public.TeamFeatureStatus a -> + Sem r (Public.TeamFeatureStatus a) setFeatureStatus setter doauth tid status = do case doauth of DoAuth uid -> do @@ -142,30 +139,9 @@ setFeatureStatus setter doauth tid status = do assertTeamExists tid setter tid status --- | Setting lock status can only be done through the internal API and therefore doesn't require auth. -setLockStatus :: - forall (a :: Public.TeamFeatureName) r. - ( Public.KnownTeamFeatureName a, - HasLockStatusCol a, - Members - [ Error ActionError, - Error TeamError, - Error NotATeamMember, - TeamStore, - TeamFeatureStore - ] - r - ) => - TeamId -> - Public.LockStatusValue -> - Sem r Public.LockStatus -setLockStatus tid lockStatusUpdate = do - assertTeamExists tid - TeamFeatures.setLockStatus @a tid (Public.LockStatus lockStatusUpdate) - -- | For individual users to get feature config for their account (personal or team). getFeatureConfig :: - forall (ps :: Public.IncludeLockStatus) (a :: Public.TeamFeatureName) r. + forall (a :: Public.TeamFeatureName) r. ( Public.KnownTeamFeatureName a, Members '[ Error ActionError, @@ -175,9 +151,9 @@ getFeatureConfig :: ] r ) => - (GetFeatureInternalParam -> Sem r (Public.TeamFeatureStatus ps a)) -> + (GetFeatureInternalParam -> Sem r (Public.TeamFeatureStatus a)) -> UserId -> - Sem r (Public.TeamFeatureStatus ps a) + Sem r (Public.TeamFeatureStatus a) getFeatureConfig getter zusr = do mbTeam <- getOneUserTeam zusr case mbTeam of @@ -204,34 +180,34 @@ getAllFeatureConfigs :: Sem r AllFeatureConfigs getAllFeatureConfigs zusr = do mbTeam <- getOneUserTeam zusr - zusrMembership <- maybe (pure Nothing) (flip getTeamMember zusr) mbTeam + zusrMembership <- maybe (pure Nothing) ((flip getTeamMember zusr)) mbTeam let getStatus :: - forall (ps :: Public.IncludeLockStatus) (a :: Public.TeamFeatureName) r. + forall (a :: Public.TeamFeatureName) r. ( Public.KnownTeamFeatureName a, - Aeson.ToJSON (Public.TeamFeatureStatus ps a), + Aeson.ToJSON (Public.TeamFeatureStatus a), Members '[Error ActionError, Error TeamError, Error NotATeamMember, TeamStore] r ) => - (GetFeatureInternalParam -> Sem r (Public.TeamFeatureStatus ps a)) -> + (GetFeatureInternalParam -> Sem r (Public.TeamFeatureStatus a)) -> Sem r (Text, Aeson.Value) getStatus getter = do when (isJust mbTeam) $ do void $ permissionCheck (ViewTeamFeature (Public.knownTeamFeatureName @a)) zusrMembership status <- getter (maybe (Left (Just zusr)) Right mbTeam) let feature = Public.knownTeamFeatureName @a - pure $ cs (toByteString' feature) Aeson..= status + pure $ (cs (toByteString' feature) Aeson..= status) AllFeatureConfigs . HashMap.fromList <$> sequence - [ getStatus @'Public.WithoutLockStatus @'Public.TeamFeatureLegalHold getLegalholdStatusInternal, - getStatus @'Public.WithoutLockStatus @'Public.TeamFeatureSSO getSSOStatusInternal, - getStatus @'Public.WithoutLockStatus @'Public.TeamFeatureSearchVisibility getTeamSearchVisibilityAvailableInternal, - getStatus @'Public.WithoutLockStatus @'Public.TeamFeatureValidateSAMLEmails getValidateSAMLEmailsInternal, - getStatus @'Public.WithoutLockStatus @'Public.TeamFeatureDigitalSignatures getDigitalSignaturesInternal, - getStatus @'Public.WithoutLockStatus @'Public.TeamFeatureAppLock getAppLockInternal, - getStatus @'Public.WithoutLockStatus @'Public.TeamFeatureFileSharing getFileSharingInternal, - getStatus @'Public.WithoutLockStatus @'Public.TeamFeatureClassifiedDomains getClassifiedDomainsInternal, - getStatus @'Public.WithoutLockStatus @'Public.TeamFeatureConferenceCalling getConferenceCallingInternal, - getStatus @'Public.WithLockStatus @'Public.TeamFeatureSelfDeletingMessages getSelfDeletingMessagesInternal + [ getStatus @'Public.TeamFeatureLegalHold getLegalholdStatusInternal, + getStatus @'Public.TeamFeatureSSO getSSOStatusInternal, + getStatus @'Public.TeamFeatureSearchVisibility getTeamSearchVisibilityAvailableInternal, + getStatus @'Public.TeamFeatureValidateSAMLEmails getValidateSAMLEmailsInternal, + getStatus @'Public.TeamFeatureDigitalSignatures getDigitalSignaturesInternal, + getStatus @'Public.TeamFeatureAppLock getAppLockInternal, + getStatus @'Public.TeamFeatureFileSharing getFileSharingInternal, + getStatus @'Public.TeamFeatureClassifiedDomains getClassifiedDomainsInternal, + getStatus @'Public.TeamFeatureConferenceCalling getConferenceCallingInternal, + getStatus @'Public.TeamFeatureSelfDeletingMessages getSelfDeletingMessagesInternal ] getAllFeaturesH :: @@ -270,57 +246,57 @@ getAllFeatures :: getAllFeatures uid tid = do Aeson.object <$> sequence - [ getStatus @'Public.WithoutLockStatus @'Public.TeamFeatureSSO getSSOStatusInternal, - getStatus @'Public.WithoutLockStatus @'Public.TeamFeatureLegalHold getLegalholdStatusInternal, - getStatus @'Public.WithoutLockStatus @'Public.TeamFeatureSearchVisibility getTeamSearchVisibilityAvailableInternal, - getStatus @'Public.WithoutLockStatus @'Public.TeamFeatureValidateSAMLEmails getValidateSAMLEmailsInternal, - getStatus @'Public.WithoutLockStatus @'Public.TeamFeatureDigitalSignatures getDigitalSignaturesInternal, - getStatus @'Public.WithoutLockStatus @'Public.TeamFeatureAppLock getAppLockInternal, - getStatus @'Public.WithoutLockStatus @'Public.TeamFeatureFileSharing getFileSharingInternal, - getStatus @'Public.WithoutLockStatus @'Public.TeamFeatureClassifiedDomains getClassifiedDomainsInternal, - getStatus @'Public.WithoutLockStatus @'Public.TeamFeatureConferenceCalling getConferenceCallingInternal, - getStatus @'Public.WithLockStatus @'Public.TeamFeatureSelfDeletingMessages getSelfDeletingMessagesInternal + [ getStatus @'Public.TeamFeatureSSO getSSOStatusInternal, + getStatus @'Public.TeamFeatureLegalHold getLegalholdStatusInternal, + getStatus @'Public.TeamFeatureSearchVisibility getTeamSearchVisibilityAvailableInternal, + getStatus @'Public.TeamFeatureValidateSAMLEmails getValidateSAMLEmailsInternal, + getStatus @'Public.TeamFeatureDigitalSignatures getDigitalSignaturesInternal, + getStatus @'Public.TeamFeatureAppLock getAppLockInternal, + getStatus @'Public.TeamFeatureFileSharing getFileSharingInternal, + getStatus @'Public.TeamFeatureClassifiedDomains getClassifiedDomainsInternal, + getStatus @'Public.TeamFeatureConferenceCalling getConferenceCallingInternal, + getStatus @'Public.TeamFeatureSelfDeletingMessages getSelfDeletingMessagesInternal ] where getStatus :: - forall (ps :: Public.IncludeLockStatus) (a :: Public.TeamFeatureName). + forall (a :: Public.TeamFeatureName). ( Public.KnownTeamFeatureName a, - Aeson.ToJSON (Public.TeamFeatureStatus ps a) + Aeson.ToJSON (Public.TeamFeatureStatus a) ) => - (GetFeatureInternalParam -> Sem r (Public.TeamFeatureStatus ps a)) -> + (GetFeatureInternalParam -> Sem r (Public.TeamFeatureStatus a)) -> Sem r (Text, Aeson.Value) getStatus getter = do - status <- getFeatureStatus @ps @a getter (DoAuth uid) tid + status <- getFeatureStatus @a getter (DoAuth uid) tid let feature = Public.knownTeamFeatureName @a - pure $ cs (toByteString' feature) Aeson..= status + pure $ (cs (toByteString' feature) Aeson..= status) getFeatureStatusNoConfig :: - forall (ps :: Public.IncludeLockStatus) (a :: Public.TeamFeatureName) r. - ( Public.FeatureHasNoConfig ps a, + forall (a :: Public.TeamFeatureName) r. + ( Public.FeatureHasNoConfig a, HasStatusCol a, Member TeamFeatureStore r ) => Sem r Public.TeamFeatureStatusValue -> TeamId -> - Sem r (Public.TeamFeatureStatus ps a) + Sem r (Public.TeamFeatureStatus a) getFeatureStatusNoConfig getDefault tid = do defaultStatus <- Public.TeamFeatureStatusNoConfig <$> getDefault - fromMaybe defaultStatus <$> TeamFeatures.getFeatureStatusNoConfig @ps @a tid + fromMaybe defaultStatus <$> TeamFeatures.getFeatureStatusNoConfig @a tid setFeatureStatusNoConfig :: - forall (ps :: Public.IncludeLockStatus) (a :: Public.TeamFeatureName) r. + forall (a :: Public.TeamFeatureName) r. ( Public.KnownTeamFeatureName a, - Public.FeatureHasNoConfig ps a, + Public.FeatureHasNoConfig a, HasStatusCol a, Members '[GundeckAccess, TeamFeatureStore, TeamStore, P.TinyLog] r ) => (Public.TeamFeatureStatusValue -> TeamId -> Sem r ()) -> TeamId -> - Public.TeamFeatureStatus ps a -> - Sem r (Public.TeamFeatureStatus ps a) + Public.TeamFeatureStatus a -> + Sem r (Public.TeamFeatureStatus a) setFeatureStatusNoConfig applyState tid status = do applyState (Public.tfwoStatus status) tid - newStatus <- TeamFeatures.setFeatureStatusNoConfig @ps @a tid status + newStatus <- TeamFeatures.setFeatureStatusNoConfig @a tid status pushFeatureConfigEvent tid $ Event.Event Event.Update (Public.knownTeamFeatureName @a) (EdFeatureWithoutConfigChanged newStatus) pure newStatus @@ -332,11 +308,11 @@ type GetFeatureInternalParam = Either (Maybe UserId) TeamId getSSOStatusInternal :: Members '[Input Opts, TeamFeatureStore] r => GetFeatureInternalParam -> - Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureSSO) + Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureSSO) getSSOStatusInternal = either (const $ Public.TeamFeatureStatusNoConfig <$> getDef) - (getFeatureStatusNoConfig @'Public.WithoutLockStatus @'Public.TeamFeatureSSO getDef) + (getFeatureStatusNoConfig @'Public.TeamFeatureSSO getDef) where getDef :: Member (Input Opts) r => Sem r Public.TeamFeatureStatusValue getDef = @@ -347,20 +323,20 @@ getSSOStatusInternal = setSSOStatusInternal :: Members '[Error TeamFeatureError, GundeckAccess, TeamFeatureStore, TeamStore, P.TinyLog] r => TeamId -> - Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureSSO -> - Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureSSO) -setSSOStatusInternal = setFeatureStatusNoConfig @'Public.WithoutLockStatus @'Public.TeamFeatureSSO $ \case + (Public.TeamFeatureStatus 'Public.TeamFeatureSSO) -> + Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureSSO) +setSSOStatusInternal = setFeatureStatusNoConfig @'Public.TeamFeatureSSO $ \case Public.TeamFeatureDisabled -> const (throw DisableSsoNotImplemented) Public.TeamFeatureEnabled -> const (pure ()) getTeamSearchVisibilityAvailableInternal :: Members '[Input Opts, TeamFeatureStore] r => GetFeatureInternalParam -> - Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureSearchVisibility) + Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureSearchVisibility) getTeamSearchVisibilityAvailableInternal = either (const $ Public.TeamFeatureStatusNoConfig <$> getDef) - (getFeatureStatusNoConfig @'Public.WithoutLockStatus @'Public.TeamFeatureSearchVisibility getDef) + (getFeatureStatusNoConfig @'Public.TeamFeatureSearchVisibility getDef) where getDef = do inputs (view (optSettings . setFeatureFlags . flagTeamSearchVisibility)) <&> \case @@ -370,20 +346,20 @@ getTeamSearchVisibilityAvailableInternal = setTeamSearchVisibilityAvailableInternal :: Members '[GundeckAccess, SearchVisibilityStore, TeamFeatureStore, TeamStore, P.TinyLog] r => TeamId -> - Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureSearchVisibility -> - Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureSearchVisibility) -setTeamSearchVisibilityAvailableInternal = setFeatureStatusNoConfig @'Public.WithoutLockStatus @'Public.TeamFeatureSearchVisibility $ \case + (Public.TeamFeatureStatus 'Public.TeamFeatureSearchVisibility) -> + Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureSearchVisibility) +setTeamSearchVisibilityAvailableInternal = setFeatureStatusNoConfig @'Public.TeamFeatureSearchVisibility $ \case Public.TeamFeatureDisabled -> SearchVisibilityData.resetSearchVisibility Public.TeamFeatureEnabled -> const (pure ()) getValidateSAMLEmailsInternal :: Member TeamFeatureStore r => GetFeatureInternalParam -> - Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureValidateSAMLEmails) + Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureValidateSAMLEmails) getValidateSAMLEmailsInternal = either (const $ Public.TeamFeatureStatusNoConfig <$> getDef) - (getFeatureStatusNoConfig @'Public.WithoutLockStatus @'Public.TeamFeatureValidateSAMLEmails getDef) + (getFeatureStatusNoConfig @'Public.TeamFeatureValidateSAMLEmails getDef) where -- FUTUREWORK: we may also want to get a default from the server config file here, like for -- sso, and team search visibility. @@ -393,18 +369,18 @@ getValidateSAMLEmailsInternal = setValidateSAMLEmailsInternal :: Members '[GundeckAccess, TeamFeatureStore, TeamStore, P.TinyLog] r => TeamId -> - Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureValidateSAMLEmails -> - Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureValidateSAMLEmails) -setValidateSAMLEmailsInternal = setFeatureStatusNoConfig @'Public.WithoutLockStatus @'Public.TeamFeatureValidateSAMLEmails $ \_ _ -> pure () + (Public.TeamFeatureStatus 'Public.TeamFeatureValidateSAMLEmails) -> + Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureValidateSAMLEmails) +setValidateSAMLEmailsInternal = setFeatureStatusNoConfig @'Public.TeamFeatureValidateSAMLEmails $ \_ _ -> pure () getDigitalSignaturesInternal :: Member TeamFeatureStore r => GetFeatureInternalParam -> - Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureDigitalSignatures) + Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureDigitalSignatures) getDigitalSignaturesInternal = either (const $ Public.TeamFeatureStatusNoConfig <$> getDef) - (getFeatureStatusNoConfig @'Public.WithoutLockStatus @'Public.TeamFeatureDigitalSignatures getDef) + (getFeatureStatusNoConfig @'Public.TeamFeatureDigitalSignatures getDef) where -- FUTUREWORK: we may also want to get a default from the server config file here, like for -- sso, and team search visibility. @@ -414,14 +390,14 @@ getDigitalSignaturesInternal = setDigitalSignaturesInternal :: Members '[GundeckAccess, TeamFeatureStore, TeamStore, P.TinyLog] r => TeamId -> - Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureDigitalSignatures -> - Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureDigitalSignatures) -setDigitalSignaturesInternal = setFeatureStatusNoConfig @'Public.WithoutLockStatus @'Public.TeamFeatureDigitalSignatures $ \_ _ -> pure () + Public.TeamFeatureStatus 'Public.TeamFeatureDigitalSignatures -> + Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureDigitalSignatures) +setDigitalSignaturesInternal = setFeatureStatusNoConfig @'Public.TeamFeatureDigitalSignatures $ \_ _ -> pure () getLegalholdStatusInternal :: Members '[LegalHoldStore, TeamFeatureStore, TeamStore] r => GetFeatureInternalParam -> - Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureLegalHold) + Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureLegalHold) getLegalholdStatusInternal (Left _) = pure $ Public.TeamFeatureStatusNoConfig Public.TeamFeatureDisabled getLegalholdStatusInternal (Right tid) = do @@ -464,8 +440,8 @@ setLegalholdStatusInternal :: r ) => TeamId -> - Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureLegalHold -> - Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureLegalHold) + Public.TeamFeatureStatus 'Public.TeamFeatureLegalHold -> + Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureLegalHold) setLegalholdStatusInternal tid status@(Public.tfwoStatus -> statusValue) = do do -- this extra do is to encapsulate the assertions running before the actual operation. @@ -485,29 +461,29 @@ setLegalholdStatusInternal tid status@(Public.tfwoStatus -> statusValue) = do Public.TeamFeatureDisabled -> removeSettings' @p tid Public.TeamFeatureEnabled -> do ensureNotTooLargeToActivateLegalHold tid - TeamFeatures.setFeatureStatusNoConfig @'Public.WithoutLockStatus @'Public.TeamFeatureLegalHold tid status + TeamFeatures.setFeatureStatusNoConfig @'Public.TeamFeatureLegalHold tid status getFileSharingInternal :: Members '[Input Opts, TeamFeatureStore] r => GetFeatureInternalParam -> - Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureFileSharing) + Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureFileSharing) getFileSharingInternal = - getFeatureStatusWithDefaultConfig @'Public.WithoutLockStatus @'Public.TeamFeatureFileSharing flagFileSharing . either (const Nothing) Just + getFeatureStatusWithDefaultConfig @'Public.TeamFeatureFileSharing flagFileSharing . either (const Nothing) Just getFeatureStatusWithDefaultConfig :: - forall (ps :: Public.IncludeLockStatus) (a :: TeamFeatureName) r. + forall (a :: TeamFeatureName) r. ( KnownTeamFeatureName a, HasStatusCol a, - FeatureHasNoConfig ps a, + FeatureHasNoConfig a, Members '[Input Opts, TeamFeatureStore] r ) => - Lens' FeatureFlags (Defaults (Public.TeamFeatureStatus ps a)) -> + Lens' FeatureFlags (Defaults (Public.TeamFeatureStatus a)) -> Maybe TeamId -> - Sem r (Public.TeamFeatureStatus ps a) + Sem r (Public.TeamFeatureStatus a) getFeatureStatusWithDefaultConfig lens' = maybe (Public.TeamFeatureStatusNoConfig <$> getDef) - (getFeatureStatusNoConfig @ps @a getDef) + (getFeatureStatusNoConfig @a getDef) where getDef :: Sem r Public.TeamFeatureStatusValue getDef = @@ -517,14 +493,14 @@ getFeatureStatusWithDefaultConfig lens' = setFileSharingInternal :: Members '[GundeckAccess, TeamFeatureStore, TeamStore, P.TinyLog] r => TeamId -> - Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureFileSharing -> - Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureFileSharing) -setFileSharingInternal = setFeatureStatusNoConfig @'Public.WithoutLockStatus @'Public.TeamFeatureFileSharing $ \_status _tid -> pure () + Public.TeamFeatureStatus 'Public.TeamFeatureFileSharing -> + Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureFileSharing) +setFileSharingInternal = setFeatureStatusNoConfig @'Public.TeamFeatureFileSharing $ \_status _tid -> pure () getAppLockInternal :: Members '[Input Opts, TeamFeatureStore] r => GetFeatureInternalParam -> - Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureAppLock) + Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureAppLock) getAppLockInternal mbtid = do Defaults defaultStatus <- inputs (view (optSettings . setFeatureFlags . flagAppLockDefaults)) status <- @@ -534,104 +510,67 @@ getAppLockInternal mbtid = do setAppLockInternal :: Members '[GundeckAccess, TeamFeatureStore, TeamStore, Error TeamFeatureError, P.TinyLog] r => TeamId -> - Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureAppLock -> - Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureAppLock) + Public.TeamFeatureStatus 'Public.TeamFeatureAppLock -> + Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureAppLock) setAppLockInternal tid status = do when (Public.applockInactivityTimeoutSecs (Public.tfwcConfig status) < 30) $ throw AppLockinactivityTimeoutTooLow let pushEvent = pushFeatureConfigEvent tid $ Event.Event Event.Update Public.TeamFeatureAppLock (EdFeatureApplockChanged status) - TeamFeatures.setApplockFeatureStatus tid status <* pushEvent + (TeamFeatures.setApplockFeatureStatus tid status) <* pushEvent getClassifiedDomainsInternal :: Member (Input Opts) r => GetFeatureInternalParam -> - Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureClassifiedDomains) + Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureClassifiedDomains) getClassifiedDomainsInternal _mbtid = do globalConfig <- inputs (view (optSettings . setFeatureFlags . flagClassifiedDomains)) let config = globalConfig pure $ case Public.tfwcStatus config of - Public.TeamFeatureDisabled -> Public.defaultClassifiedDomains + Public.TeamFeatureDisabled -> + Public.TeamFeatureStatusWithConfig Public.TeamFeatureDisabled (Public.TeamFeatureClassifiedDomainsConfig []) Public.TeamFeatureEnabled -> config getConferenceCallingInternal :: Members '[BrigAccess, Input Opts, TeamFeatureStore] r => GetFeatureInternalParam -> - Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureConferenceCalling) + Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureConferenceCalling) getConferenceCallingInternal (Left (Just uid)) = do getFeatureConfigViaAccount @'Public.TeamFeatureConferenceCalling uid getConferenceCallingInternal (Left Nothing) = do - getFeatureStatusWithDefaultConfig @'Public.WithoutLockStatus @'Public.TeamFeatureConferenceCalling flagConferenceCalling Nothing + getFeatureStatusWithDefaultConfig @'Public.TeamFeatureConferenceCalling flagConferenceCalling Nothing getConferenceCallingInternal (Right tid) = do - getFeatureStatusWithDefaultConfig @'Public.WithoutLockStatus @'Public.TeamFeatureConferenceCalling flagConferenceCalling (Just tid) + getFeatureStatusWithDefaultConfig @'Public.TeamFeatureConferenceCalling flagConferenceCalling (Just tid) setConferenceCallingInternal :: Members '[GundeckAccess, TeamFeatureStore, TeamStore, P.TinyLog] r => TeamId -> - Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureConferenceCalling -> - Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureConferenceCalling) + Public.TeamFeatureStatus 'Public.TeamFeatureConferenceCalling -> + Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureConferenceCalling) setConferenceCallingInternal = - setFeatureStatusNoConfig @'Public.WithoutLockStatus @'Public.TeamFeatureConferenceCalling $ \_status _tid -> pure () + setFeatureStatusNoConfig @'Public.TeamFeatureConferenceCalling $ \_status _tid -> pure () getSelfDeletingMessagesInternal :: - forall r. - ( Member (Input Opts) r, - Member TeamFeatureStore r - ) => + Member TeamFeatureStore r => GetFeatureInternalParam -> - Sem r (Public.TeamFeatureStatus 'Public.WithLockStatus 'Public.TeamFeatureSelfDeletingMessages) + Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureSelfDeletingMessages) getSelfDeletingMessagesInternal = \case - Left _ -> getCfgDefault - Right tid -> do - cfgDefault <- getCfgDefault - let defLockStatus = Public.tfwcapsLockStatus cfgDefault - (maybeFeatureStatus, fromMaybe defLockStatus -> lockStatus) <- TeamFeatures.getSelfDeletingMessagesStatus tid - pure $ case (lockStatus, maybeFeatureStatus) of - (Public.Unlocked, Just featureStatus) -> - Public.TeamFeatureStatusWithConfigAndLockStatus - (Public.tfwcStatus featureStatus) - (Public.tfwcConfig featureStatus) - Public.Unlocked - (Public.Unlocked, Nothing) -> cfgDefault {Public.tfwcapsLockStatus = Public.Unlocked} - (Public.Locked, _) -> cfgDefault {Public.tfwcapsLockStatus = Public.Locked} - where - getCfgDefault :: Sem r (Public.TeamFeatureStatusWithConfigAndLockStatus Public.TeamFeatureSelfDeletingMessagesConfig) - getCfgDefault = input <&> view (optSettings . setFeatureFlags . flagSelfDeletingMessages . unDefaults) + Left _ -> pure Public.defaultSelfDeletingMessagesStatus + Right tid -> + TeamFeatures.getSelfDeletingMessagesStatus tid + <&> maybe Public.defaultSelfDeletingMessagesStatus id setSelfDeletingMessagesInternal :: - Members - '[ GundeckAccess, - TeamStore, - TeamFeatureStore, - P.TinyLog, - Error TeamFeatureError - ] - r => + Members '[GundeckAccess, TeamFeatureStore, TeamStore, P.TinyLog] r => TeamId -> - Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureSelfDeletingMessages -> - Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureSelfDeletingMessages) + Public.TeamFeatureStatus 'Public.TeamFeatureSelfDeletingMessages -> + Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureSelfDeletingMessages) setSelfDeletingMessagesInternal tid st = do - guardLockStatus @'Public.TeamFeatureSelfDeletingMessages tid Public.Locked let pushEvent = pushFeatureConfigEvent tid $ Event.Event Event.Update Public.TeamFeatureSelfDeletingMessages (EdFeatureSelfDeletingMessagesChanged st) - TeamFeatures.setSelfDeletingMessagesStatus tid st <* pushEvent - --- TODO(fisx): move this function to a more suitable place / module. -guardLockStatus :: - forall (a :: Public.TeamFeatureName) r. - ( MaybeHasLockStatusCol a, - Member TeamFeatureStore r, - Member (Error TeamFeatureError) r - ) => - TeamId -> - Public.LockStatusValue -> -- FUTUREWORK(fisx): move this into its own type class and infer from `a`? - Sem r () -guardLockStatus tid defLockStatus = do - (TeamFeatures.getLockStatus @a tid <&> fromMaybe defLockStatus) >>= \case - Public.Unlocked -> pure () - Public.Locked -> throw FeatureLocked + (TeamFeatures.setSelfDeletingMessagesStatus tid st) <* pushEvent pushFeatureConfigEvent :: Members '[GundeckAccess, TeamStore, P.TinyLog] r => @@ -649,7 +588,7 @@ pushFeatureConfigEvent tid event = do let recipients = membersToRecipients Nothing (memList ^. teamMembers) for_ (newPush (memList ^. teamMemberListType) Nothing (FeatureConfigEvent event) recipients) - push1 + (push1) -- | (Currently, we only have 'Public.TeamFeatureConferenceCalling' here, but we may have to -- extend this in the future.) @@ -658,5 +597,5 @@ getFeatureConfigViaAccount :: Member BrigAccess r ) => UserId -> - Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus flag) + Sem r (Public.TeamFeatureStatus flag) getFeatureConfigViaAccount = getAccountFeatureConfigClient diff --git a/services/galley/src/Galley/Cassandra.hs b/services/galley/src/Galley/Cassandra.hs index 83a0a5abd1f..a32e4fdce1a 100644 --- a/services/galley/src/Galley/Cassandra.hs +++ b/services/galley/src/Galley/Cassandra.hs @@ -20,4 +20,4 @@ module Galley.Cassandra (schemaVersion) where import Imports schemaVersion :: Int32 -schemaVersion = 55 +schemaVersion = 54 diff --git a/services/galley/src/Galley/Cassandra/TeamFeatures.hs b/services/galley/src/Galley/Cassandra/TeamFeatures.hs index c72d549f656..e723fe47689 100644 --- a/services/galley/src/Galley/Cassandra/TeamFeatures.hs +++ b/services/galley/src/Galley/Cassandra/TeamFeatures.hs @@ -30,16 +30,15 @@ import Polysemy.Input import Wire.API.Team.Feature getFeatureStatusNoConfig :: - forall (ps :: IncludeLockStatus) (a :: TeamFeatureName) m. + forall (a :: TeamFeatureName) m. ( MonadClient m, - FeatureHasNoConfig ps a, + FeatureHasNoConfig a, HasStatusCol a ) => - Proxy ps -> Proxy a -> TeamId -> - m (Maybe (TeamFeatureStatus ps a)) -getFeatureStatusNoConfig _ _ tid = do + m (Maybe (TeamFeatureStatus a)) +getFeatureStatusNoConfig _ tid = do let q = query1 select (params LocalQuorum (Identity tid)) mStatusValue <- (>>= runIdentity) <$> retry x1 q pure $ TeamFeatureStatusNoConfig <$> mStatusValue @@ -48,17 +47,16 @@ getFeatureStatusNoConfig _ _ tid = do select = fromString $ "select " <> statusCol @a <> " from team_features where team_id = ?" setFeatureStatusNoConfig :: - forall (ps :: IncludeLockStatus) (a :: TeamFeatureName) m. + forall (a :: TeamFeatureName) m. ( MonadClient m, - FeatureHasNoConfig ps a, + FeatureHasNoConfig a, HasStatusCol a ) => - Proxy ps -> Proxy a -> TeamId -> - TeamFeatureStatus ps a -> - m (TeamFeatureStatus ps a) -setFeatureStatusNoConfig _ _ tid status = do + TeamFeatureStatus a -> + m (TeamFeatureStatus a) +setFeatureStatusNoConfig _ tid status = do let flag = tfwoStatus status retry x5 $ write insert (params LocalQuorum (tid, flag)) pure status @@ -70,7 +68,7 @@ getApplockFeatureStatus :: forall m. (MonadClient m) => TeamId -> - m (Maybe (TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureAppLock)) + m (Maybe (TeamFeatureStatus 'TeamFeatureAppLock)) getApplockFeatureStatus tid = do let q = query1 select (params LocalQuorum (Identity tid)) mTuple <- retry x1 q @@ -87,8 +85,8 @@ getApplockFeatureStatus tid = do setApplockFeatureStatus :: (MonadClient m) => TeamId -> - TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureAppLock -> - m (TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureAppLock) + TeamFeatureStatus 'TeamFeatureAppLock -> + m (TeamFeatureStatus 'TeamFeatureAppLock) setApplockFeatureStatus tid status = do let statusValue = tfwcStatus status enforce = applockEnforceAppLock . tfwcConfig $ status @@ -107,30 +105,27 @@ getSelfDeletingMessagesStatus :: forall m. (MonadClient m) => TeamId -> - m (Maybe (TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureSelfDeletingMessages), Maybe LockStatusValue) + m (Maybe (TeamFeatureStatus 'TeamFeatureSelfDeletingMessages)) getSelfDeletingMessagesStatus tid = do let q = query1 select (params LocalQuorum (Identity tid)) mTuple <- retry x1 q - pure - ( mTuple >>= \(mbStatusValue, mbTimeout, _) -> - TeamFeatureStatusWithConfig <$> mbStatusValue <*> (TeamFeatureSelfDeletingMessagesConfig <$> mbTimeout), - mTuple >>= \(_, _, mbLockStatus) -> mbLockStatus - ) + pure $ + mTuple >>= \(mbStatusValue, mbTimeout) -> + TeamFeatureStatusWithConfig <$> mbStatusValue <*> (TeamFeatureSelfDeletingMessagesConfig <$> mbTimeout) where - select :: PrepQuery R (Identity TeamId) (Maybe TeamFeatureStatusValue, Maybe Int32, Maybe LockStatusValue) + select :: PrepQuery R (Identity TeamId) (Maybe TeamFeatureStatusValue, Maybe Int32) select = fromString $ "select " <> statusCol @'TeamFeatureSelfDeletingMessages - <> ", self_deleting_messages_ttl, " - <> lockStatusCol @'TeamFeatureSelfDeletingMessages - <> " from team_features where team_id = ?" + <> ", self_deleting_messages_ttl " + <> "from team_features where team_id = ?" setSelfDeletingMessagesStatus :: (MonadClient m) => TeamId -> - TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureSelfDeletingMessages -> - m (TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureSelfDeletingMessages) + TeamFeatureStatus 'TeamFeatureSelfDeletingMessages -> + m (TeamFeatureStatus 'TeamFeatureSelfDeletingMessages) setSelfDeletingMessagesStatus tid status = do let statusValue = tfwcStatus status timeout = sdmEnforcedTimeoutSeconds . tfwcConfig $ status @@ -145,55 +140,13 @@ setSelfDeletingMessagesStatus tid status = do <> ", self_deleting_messages_ttl) " <> "values (?, ?, ?)" -setLockStatus :: - forall (a :: TeamFeatureName) m. - ( MonadClient m, - HasLockStatusCol a - ) => - Proxy a -> - TeamId -> - LockStatus -> - m LockStatus -setLockStatus _ tid (LockStatus lockStatus) = do - retry x5 $ write insert (params LocalQuorum (tid, lockStatus)) - pure (LockStatus lockStatus) - where - insert :: PrepQuery W (TeamId, LockStatusValue) () - insert = - fromString $ - "insert into team_features (team_id, " <> lockStatusCol @a <> ") values (?, ?)" - -getLockStatus :: - forall (a :: TeamFeatureName) m. - ( MonadClient m, - MaybeHasLockStatusCol a - ) => - Proxy a -> - TeamId -> - m (Maybe LockStatusValue) -getLockStatus _ tid = - case maybeLockStatusCol @a of - Nothing -> pure Nothing - Just lockStatusColName -> do - let q = query1 select (params LocalQuorum (Identity tid)) - (>>= runIdentity) <$> retry x1 q - where - select :: PrepQuery R (Identity TeamId) (Identity (Maybe LockStatusValue)) - select = - fromString $ - "select " - <> lockStatusColName - <> " from team_features where team_id = ?" - interpretTeamFeatureStoreToCassandra :: Members '[Embed IO, Input ClientState] r => Sem (TeamFeatureStore ': r) a -> Sem r a interpretTeamFeatureStoreToCassandra = interpret $ \case - GetFeatureStatusNoConfig' ps tfn tid -> embedClient $ getFeatureStatusNoConfig ps tfn tid - SetFeatureStatusNoConfig' ps tfn tid value -> embedClient $ setFeatureStatusNoConfig ps tfn tid value - SetLockStatus' p tid value -> embedClient $ setLockStatus p tid value - GetLockStatus' p tid -> embedClient $ getLockStatus p tid + GetFeatureStatusNoConfig' p tid -> embedClient $ getFeatureStatusNoConfig p tid + SetFeatureStatusNoConfig' p tid value -> embedClient $ setFeatureStatusNoConfig p tid value GetApplockFeatureStatus tid -> embedClient $ getApplockFeatureStatus tid SetApplockFeatureStatus tid value -> embedClient $ setApplockFeatureStatus tid value GetSelfDeletingMessagesStatus tid -> embedClient $ getSelfDeletingMessagesStatus tid diff --git a/services/galley/src/Galley/Data/TeamFeatures.hs b/services/galley/src/Galley/Data/TeamFeatures.hs index 65a6cc6648b..e7ab337d0f5 100644 --- a/services/galley/src/Galley/Data/TeamFeatures.hs +++ b/services/galley/src/Galley/Data/TeamFeatures.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.Data.TeamFeatures (HasStatusCol (..), HasLockStatusCol (..), MaybeHasLockStatusCol (..)) where +module Galley.Data.TeamFeatures (HasStatusCol (..)) where import Imports import Wire.API.Team.Feature @@ -48,33 +48,3 @@ instance HasStatusCol 'TeamFeatureFileSharing where statusCol = "file_sharing" instance HasStatusCol 'TeamFeatureConferenceCalling where statusCol = "conference_calling" instance HasStatusCol 'TeamFeatureSelfDeletingMessages where statusCol = "self_deleting_messages_status" - ----------------------------------------------------------------------- -class HasLockStatusCol (a :: TeamFeatureName) where - lockStatusCol :: String - -class MaybeHasLockStatusCol (a :: TeamFeatureName) where - maybeLockStatusCol :: Maybe String - -instance {-# OVERLAPPABLE #-} HasLockStatusCol a => MaybeHasLockStatusCol a where - maybeLockStatusCol = Just (lockStatusCol @a) - ----------------------------------------------------------------------- -instance HasLockStatusCol 'TeamFeatureSelfDeletingMessages where - lockStatusCol = "self_deleting_messages_lock_status" - -instance MaybeHasLockStatusCol 'TeamFeatureLegalHold where maybeLockStatusCol = Nothing - -instance MaybeHasLockStatusCol 'TeamFeatureSSO where maybeLockStatusCol = Nothing - -instance MaybeHasLockStatusCol 'TeamFeatureSearchVisibility where maybeLockStatusCol = Nothing - -instance MaybeHasLockStatusCol 'TeamFeatureValidateSAMLEmails where maybeLockStatusCol = Nothing - -instance MaybeHasLockStatusCol 'TeamFeatureDigitalSignatures where maybeLockStatusCol = Nothing - -instance MaybeHasLockStatusCol 'TeamFeatureAppLock where maybeLockStatusCol = Nothing - -instance MaybeHasLockStatusCol 'TeamFeatureFileSharing where maybeLockStatusCol = Nothing - -instance MaybeHasLockStatusCol 'TeamFeatureConferenceCalling where maybeLockStatusCol = Nothing diff --git a/services/galley/src/Galley/Effects/TeamFeatureStore.hs b/services/galley/src/Galley/Effects/TeamFeatureStore.hs index 8e5673ba242..d2910980f20 100644 --- a/services/galley/src/Galley/Effects/TeamFeatureStore.hs +++ b/services/galley/src/Galley/Effects/TeamFeatureStore.hs @@ -23,8 +23,6 @@ module Galley.Effects.TeamFeatureStore setApplockFeatureStatus, getSelfDeletingMessagesStatus, setSelfDeletingMessagesStatus, - setLockStatus, - getLockStatus, ) where @@ -38,83 +36,51 @@ import Wire.API.Team.Feature data TeamFeatureStore m a where -- the proxy argument makes sure that makeSem below generates type-inference-friendly code GetFeatureStatusNoConfig' :: - forall (ps :: IncludeLockStatus) (a :: TeamFeatureName) m. - ( FeatureHasNoConfig ps a, + forall (a :: TeamFeatureName) m. + ( FeatureHasNoConfig a, HasStatusCol a ) => - Proxy ps -> Proxy a -> TeamId -> - TeamFeatureStore m (Maybe (TeamFeatureStatus ps a)) + TeamFeatureStore m (Maybe (TeamFeatureStatus a)) -- the proxy argument makes sure that makeSem below generates type-inference-friendly code SetFeatureStatusNoConfig' :: - forall (ps :: IncludeLockStatus) (a :: TeamFeatureName) m. - ( FeatureHasNoConfig ps a, + forall (a :: TeamFeatureName) m. + ( FeatureHasNoConfig a, HasStatusCol a ) => - Proxy ps -> Proxy a -> TeamId -> - TeamFeatureStatus ps a -> - TeamFeatureStore m (TeamFeatureStatus ps a) + TeamFeatureStatus a -> + TeamFeatureStore m (TeamFeatureStatus a) GetApplockFeatureStatus :: TeamId -> - TeamFeatureStore m (Maybe (TeamFeatureStatus ps 'TeamFeatureAppLock)) + TeamFeatureStore m (Maybe (TeamFeatureStatus 'TeamFeatureAppLock)) SetApplockFeatureStatus :: TeamId -> - TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureAppLock -> - TeamFeatureStore m (TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureAppLock) + TeamFeatureStatus 'TeamFeatureAppLock -> + TeamFeatureStore m (TeamFeatureStatus 'TeamFeatureAppLock) GetSelfDeletingMessagesStatus :: TeamId -> - TeamFeatureStore m (Maybe (TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureSelfDeletingMessages), Maybe LockStatusValue) + TeamFeatureStore m (Maybe (TeamFeatureStatus 'TeamFeatureSelfDeletingMessages)) SetSelfDeletingMessagesStatus :: TeamId -> - TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureSelfDeletingMessages -> - TeamFeatureStore m (TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureSelfDeletingMessages) - SetLockStatus' :: - forall (a :: TeamFeatureName) m. - ( HasLockStatusCol a - ) => - Proxy a -> - TeamId -> - LockStatus -> - TeamFeatureStore m LockStatus - GetLockStatus' :: - forall (a :: TeamFeatureName) m. - ( MaybeHasLockStatusCol a - ) => - Proxy a -> - TeamId -> - TeamFeatureStore m (Maybe LockStatusValue) + TeamFeatureStatus 'TeamFeatureSelfDeletingMessages -> + TeamFeatureStore m (TeamFeatureStatus 'TeamFeatureSelfDeletingMessages) makeSem ''TeamFeatureStore getFeatureStatusNoConfig :: - forall (ps :: IncludeLockStatus) (a :: TeamFeatureName) r. - (Member TeamFeatureStore r, FeatureHasNoConfig ps a, HasStatusCol a) => - TeamId -> - Sem r (Maybe (TeamFeatureStatus ps a)) -getFeatureStatusNoConfig = getFeatureStatusNoConfig' (Proxy @ps) (Proxy @a) - -setFeatureStatusNoConfig :: - forall (ps :: IncludeLockStatus) (a :: TeamFeatureName) r. - (Member TeamFeatureStore r, FeatureHasNoConfig ps a, HasStatusCol a) => - TeamId -> - TeamFeatureStatus ps a -> - Sem r (TeamFeatureStatus ps a) -setFeatureStatusNoConfig = setFeatureStatusNoConfig' (Proxy @ps) (Proxy @a) - -setLockStatus :: forall (a :: TeamFeatureName) r. - (Member TeamFeatureStore r, HasLockStatusCol a) => + (Member TeamFeatureStore r, FeatureHasNoConfig a, HasStatusCol a) => TeamId -> - LockStatus -> - Sem r LockStatus -setLockStatus = setLockStatus' (Proxy @a) + Sem r (Maybe (TeamFeatureStatus a)) +getFeatureStatusNoConfig = getFeatureStatusNoConfig' (Proxy @a) -getLockStatus :: +setFeatureStatusNoConfig :: forall (a :: TeamFeatureName) r. - (Member TeamFeatureStore r, MaybeHasLockStatusCol a) => + (Member TeamFeatureStore r, FeatureHasNoConfig a, HasStatusCol a) => TeamId -> - Sem r (Maybe LockStatusValue) -getLockStatus = getLockStatus' (Proxy @a) + TeamFeatureStatus a -> + Sem r (TeamFeatureStatus a) +setFeatureStatusNoConfig = setFeatureStatusNoConfig' (Proxy @a) diff --git a/services/galley/test/integration/API/Teams.hs b/services/galley/test/integration/API/Teams.hs index a1edf78225a..43985abb00b 100644 --- a/services/galley/test/integration/API/Teams.hs +++ b/services/galley/test/integration/API/Teams.hs @@ -355,7 +355,7 @@ testEnableSSOPerTeam = do assertQueue "create team" tActivate let check :: HasCallStack => String -> Public.TeamFeatureStatusValue -> TestM () check msg enabledness = do - status :: Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureSSO <- responseJsonUnsafe <$> (getSSOEnabledInternal tid (getSSOEnabledInternal tid TestM () @@ -382,10 +382,10 @@ testEnableSSOPerTeam = do testEnableTeamSearchVisibilityPerTeam :: TestM () testEnableTeamSearchVisibilityPerTeam = do g <- view tsGalley - (tid, owner, member : _) <- Util.createBindingTeamWithMembers 2 + (tid, owner, (member : _)) <- Util.createBindingTeamWithMembers 2 let check :: (HasCallStack, MonadCatch m, MonadIO m, Monad m, MonadHttp m) => String -> Public.TeamFeatureStatusValue -> m () check msg enabledness = do - status :: Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureSearchVisibility <- responseJsonUnsafe <$> (Util.getTeamSearchVisibilityAvailableInternal g tid (Util.getTeamSearchVisibilityAvailableInternal g tid return (x, xs) (201, 200, _, _) -> createAndConnectUserWhileLimitNotReached alice (remaining -1) ((uid, cid) : acc) pk (403, 403, _, []) -> error "Need to connect with at least 1 user" - (403, 403, _, x : xs) -> return (x, xs) + (403, 403, _, (x : xs)) -> return (x, xs) (xxx, yyy, _, _) -> error ("Unexpected while connecting users: " ++ show xxx ++ " and " ++ show yyy) newTeamMember' :: Permissions -> UserId -> TeamMember @@ -1892,7 +1892,7 @@ getSSOEnabledInternal :: HasCallStack => TeamId -> TestM ResponseLBS getSSOEnabledInternal = Util.getTeamFeatureFlagInternal Public.TeamFeatureSSO putSSOEnabledInternal :: HasCallStack => TeamId -> Public.TeamFeatureStatusValue -> TestM () -putSSOEnabledInternal tid statusValue = void $ Util.putTeamFeatureFlagInternal @'Public.WithoutLockStatus @'Public.TeamFeatureSSO expect2xx tid (Public.TeamFeatureStatusNoConfig statusValue) +putSSOEnabledInternal tid statusValue = Util.putTeamFeatureFlagInternal @'Public.TeamFeatureSSO expect2xx tid (Public.TeamFeatureStatusNoConfig statusValue) getSearchVisibility :: HasCallStack => (Request -> Request) -> UserId -> TeamId -> (MonadIO m, MonadHttp m) => m ResponseLBS getSearchVisibility g uid tid = do diff --git a/services/galley/test/integration/API/Teams/Feature.hs b/services/galley/test/integration/API/Teams/Feature.hs index ba2a64110d5..76c5f7b408d 100644 --- a/services/galley/test/integration/API/Teams/Feature.hs +++ b/services/galley/test/integration/API/Teams/Feature.hs @@ -22,7 +22,7 @@ import qualified API.Util as Util import qualified API.Util.TeamFeature as Util import Bilge import Bilge.Assert -import Control.Lens (over, to, view) +import Control.Lens (over, view) import Control.Monad.Catch (MonadCatch) import Data.Aeson (FromJSON, ToJSON, object, (.=)) import qualified Data.Aeson as Aeson @@ -60,15 +60,15 @@ tests s = [ test s "SSO" testSSO, test s "LegalHold" testLegalHold, test s "SearchVisibility" testSearchVisibility, - test s "DigitalSignatures" $ testSimpleFlag @'Public.WithoutLockStatus @'Public.TeamFeatureDigitalSignatures Public.TeamFeatureDisabled, - test s "ValidateSAMLEmails" $ testSimpleFlag @'Public.WithoutLockStatus @'Public.TeamFeatureValidateSAMLEmails Public.TeamFeatureDisabled, - test s "FileSharing" $ testSimpleFlag @'Public.WithoutLockStatus @'Public.TeamFeatureFileSharing Public.TeamFeatureEnabled, + test s "DigitalSignatures" $ testSimpleFlag @'Public.TeamFeatureDigitalSignatures Public.TeamFeatureDisabled, + test s "ValidateSAMLEmails" $ testSimpleFlag @'Public.TeamFeatureValidateSAMLEmails Public.TeamFeatureDisabled, + test s "FileSharing" $ testSimpleFlag @'Public.TeamFeatureFileSharing Public.TeamFeatureEnabled, test s "Classified Domains (enabled)" testClassifiedDomainsEnabled, test s "Classified Domains (disabled)" testClassifiedDomainsDisabled, test s "All features" testAllFeatures, test s "Feature Configs / Team Features Consistency" testFeatureConfigConsistency, - test s "ConferenceCalling" $ testSimpleFlag @'Public.WithoutLockStatus @'Public.TeamFeatureConferenceCalling Public.TeamFeatureEnabled, - test s "SelfDeletingMessages" testSelfDeletingMessages + test s "ConferenceCalling" $ testSimpleFlag @'Public.TeamFeatureConferenceCalling Public.TeamFeatureEnabled, + test s "SelfDeletingMessages" $ testSelfDeletingMessages ] testSSO :: TestM () @@ -81,13 +81,13 @@ testSSO = do Util.addTeamMember owner tid member (rolePermissions RoleMember) Nothing let getSSO :: HasCallStack => Public.TeamFeatureStatusValue -> TestM () - getSSO = assertFlagNoConfig @'Public.WithoutLockStatus @'Public.TeamFeatureSSO $ Util.getTeamFeatureFlag Public.TeamFeatureSSO member tid + getSSO = assertFlagNoConfig @'Public.TeamFeatureSSO $ Util.getTeamFeatureFlag Public.TeamFeatureSSO member tid getSSOFeatureConfig :: HasCallStack => Public.TeamFeatureStatusValue -> TestM () - getSSOFeatureConfig = assertFlagNoConfig @'Public.WithoutLockStatus @'Public.TeamFeatureSSO $ Util.getFeatureConfig Public.TeamFeatureSSO member + getSSOFeatureConfig = assertFlagNoConfig @'Public.TeamFeatureSSO $ Util.getFeatureConfig Public.TeamFeatureSSO member getSSOInternal :: HasCallStack => Public.TeamFeatureStatusValue -> TestM () - getSSOInternal = assertFlagNoConfig @'Public.WithoutLockStatus @'Public.TeamFeatureSSO $ Util.getTeamFeatureFlagInternal Public.TeamFeatureSSO tid + getSSOInternal = assertFlagNoConfig @'Public.TeamFeatureSSO $ Util.getTeamFeatureFlagInternal Public.TeamFeatureSSO tid setSSOInternal :: HasCallStack => Public.TeamFeatureStatusValue -> TestM () - setSSOInternal = void . Util.putTeamFeatureFlagInternal @'Public.WithoutLockStatus @'Public.TeamFeatureSSO expect2xx tid . Public.TeamFeatureStatusNoConfig + setSSOInternal = Util.putTeamFeatureFlagInternal @'Public.TeamFeatureSSO expect2xx tid . Public.TeamFeatureStatusNoConfig assertFlagForbidden $ Util.getTeamFeatureFlag Public.TeamFeatureSSO nonMember tid @@ -121,13 +121,13 @@ testLegalHold = do Util.addTeamMember owner tid member (rolePermissions RoleMember) Nothing let getLegalHold :: HasCallStack => Public.TeamFeatureStatusValue -> TestM () - getLegalHold = assertFlagNoConfig @'Public.WithoutLockStatus @'Public.TeamFeatureLegalHold $ Util.getTeamFeatureFlag Public.TeamFeatureLegalHold member tid + getLegalHold = assertFlagNoConfig @'Public.TeamFeatureLegalHold $ Util.getTeamFeatureFlag Public.TeamFeatureLegalHold member tid getLegalHoldInternal :: HasCallStack => Public.TeamFeatureStatusValue -> TestM () - getLegalHoldInternal = assertFlagNoConfig @'Public.WithoutLockStatus @'Public.TeamFeatureLegalHold $ Util.getTeamFeatureFlagInternal Public.TeamFeatureLegalHold tid - getLegalHoldFeatureConfig = assertFlagNoConfig @'Public.WithoutLockStatus @'Public.TeamFeatureLegalHold $ Util.getFeatureConfig Public.TeamFeatureLegalHold member + getLegalHoldInternal = assertFlagNoConfig @'Public.TeamFeatureLegalHold $ Util.getTeamFeatureFlagInternal Public.TeamFeatureLegalHold tid + getLegalHoldFeatureConfig = assertFlagNoConfig @'Public.TeamFeatureLegalHold $ Util.getFeatureConfig Public.TeamFeatureLegalHold member setLegalHoldInternal :: HasCallStack => Public.TeamFeatureStatusValue -> TestM () - setLegalHoldInternal = void . Util.putTeamFeatureFlagInternal @'Public.WithoutLockStatus @'Public.TeamFeatureLegalHold expect2xx tid . Public.TeamFeatureStatusNoConfig + setLegalHoldInternal = Util.putTeamFeatureFlagInternal @'Public.TeamFeatureLegalHold expect2xx tid . Public.TeamFeatureStatusNoConfig getLegalHold Public.TeamFeatureDisabled getLegalHoldInternal Public.TeamFeatureDisabled @@ -249,7 +249,7 @@ getClassifiedDomains :: (HasCallStack, HasGalley m, MonadIO m, MonadHttp m, MonadCatch m) => UserId -> TeamId -> - Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureClassifiedDomains -> + Public.TeamFeatureStatus 'Public.TeamFeatureClassifiedDomains -> m () getClassifiedDomains member tid = assertFlagWithConfig @Public.TeamFeatureClassifiedDomainsConfig $ @@ -258,7 +258,7 @@ getClassifiedDomains member tid = getClassifiedDomainsInternal :: (HasCallStack, HasGalley m, MonadIO m, MonadHttp m, MonadCatch m) => TeamId -> - Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureClassifiedDomains -> + Public.TeamFeatureStatus 'Public.TeamFeatureClassifiedDomains -> m () getClassifiedDomainsInternal tid = assertFlagWithConfig @Public.TeamFeatureClassifiedDomainsConfig $ @@ -276,7 +276,7 @@ testClassifiedDomainsEnabled = do let getClassifiedDomainsFeatureConfig :: (HasCallStack, HasGalley m, MonadIO m, MonadHttp m, MonadCatch m) => UserId -> - Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureClassifiedDomains -> + Public.TeamFeatureStatus 'Public.TeamFeatureClassifiedDomains -> m () getClassifiedDomainsFeatureConfig uid = do assertFlagWithConfig @Public.TeamFeatureClassifiedDomainsConfig $ @@ -298,7 +298,7 @@ testClassifiedDomainsDisabled = do let getClassifiedDomainsFeatureConfig :: (HasCallStack, HasGalley m, MonadIO m, MonadHttp m, MonadCatch m) => UserId -> - Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureClassifiedDomains -> + Public.TeamFeatureStatus 'Public.TeamFeatureClassifiedDomains -> m () getClassifiedDomainsFeatureConfig uid = do assertFlagWithConfig @Public.TeamFeatureClassifiedDomainsConfig $ @@ -316,13 +316,13 @@ testClassifiedDomainsDisabled = do getClassifiedDomainsFeatureConfig member expected testSimpleFlag :: - forall (ps :: Public.IncludeLockStatus) (a :: Public.TeamFeatureName). + forall (a :: Public.TeamFeatureName). ( HasCallStack, Typeable a, - Public.FeatureHasNoConfig ps a, + Public.FeatureHasNoConfig a, Public.KnownTeamFeatureName a, - FromJSON (Public.TeamFeatureStatus 'Public.WithoutLockStatus a), - ToJSON (Public.TeamFeatureStatus ps a) + FromJSON (Public.TeamFeatureStatus a), + ToJSON (Public.TeamFeatureStatus a) ) => Public.TeamFeatureStatusValue -> TestM () @@ -337,19 +337,19 @@ testSimpleFlag defaultValue = do let getFlag :: HasCallStack => Public.TeamFeatureStatusValue -> TestM () getFlag expected = - flip (assertFlagNoConfig @ps @a) expected $ Util.getTeamFeatureFlag feature member tid + flip (assertFlagNoConfig @a) expected $ Util.getTeamFeatureFlag feature member tid getFeatureConfig :: HasCallStack => Public.TeamFeatureStatusValue -> TestM () getFeatureConfig expected = - flip (assertFlagNoConfig @ps @a) expected $ Util.getFeatureConfig feature member + flip (assertFlagNoConfig @a) expected $ Util.getFeatureConfig feature member getFlagInternal :: HasCallStack => Public.TeamFeatureStatusValue -> TestM () getFlagInternal expected = - flip (assertFlagNoConfig @ps @a) expected $ Util.getTeamFeatureFlagInternal feature tid + flip (assertFlagNoConfig @a) expected $ Util.getTeamFeatureFlagInternal feature tid setFlagInternal :: Public.TeamFeatureStatusValue -> TestM () setFlagInternal statusValue = - void $ Util.putTeamFeatureFlagInternal @ps @a expect2xx tid (Public.TeamFeatureStatusNoConfig statusValue) + Util.putTeamFeatureFlagInternal @a expect2xx tid (Public.TeamFeatureStatusNoConfig statusValue) assertFlagForbidden $ Util.getTeamFeatureFlag feature nonMember tid @@ -380,50 +380,32 @@ testSimpleFlag defaultValue = do testSelfDeletingMessages :: TestM () testSelfDeletingMessages = do - defLockStatus :: Public.LockStatusValue <- - view - ( tsGConf - . optSettings - . setFeatureFlags - . flagSelfDeletingMessages - . unDefaults - . to Public.tfwcapsLockStatus - ) - -- personal users - let settingWithoutLockStatus :: TeamFeatureStatusValue -> Int32 -> Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureSelfDeletingMessages - settingWithoutLockStatus stat tout = + let setting :: TeamFeatureStatusValue -> Int32 -> Public.TeamFeatureStatus 'Public.TeamFeatureSelfDeletingMessages + setting stat tout = Public.TeamFeatureStatusWithConfig @Public.TeamFeatureSelfDeletingMessagesConfig stat (Public.TeamFeatureSelfDeletingMessagesConfig tout) - settingWithLockStatus :: TeamFeatureStatusValue -> Int32 -> Public.LockStatusValue -> Public.TeamFeatureStatus 'Public.WithLockStatus 'Public.TeamFeatureSelfDeletingMessages - settingWithLockStatus stat tout lockStatus = - Public.TeamFeatureStatusWithConfigAndLockStatus @Public.TeamFeatureSelfDeletingMessagesConfig - stat - (Public.TeamFeatureSelfDeletingMessagesConfig tout) - lockStatus personalUser <- Util.randomUser Util.getFeatureConfig Public.TeamFeatureSelfDeletingMessages personalUser - !!! responseJsonEither === const (Right $ settingWithLockStatus TeamFeatureEnabled 0 defLockStatus) + !!! responseJsonEither === const (Right $ setting TeamFeatureEnabled 0) -- team users galley <- view tsGalley (owner, tid, []) <- Util.createBindingTeamWithNMembers 0 - let checkSet :: TeamFeatureStatusValue -> Int32 -> Int -> TestM () - checkSet stat tout expectedStatusCode = - do - Util.putTeamFeatureFlagInternal @'Public.WithoutLockStatus @'Public.TeamFeatureSelfDeletingMessages - galley - tid - (settingWithoutLockStatus stat tout) - !!! statusCode === const expectedStatusCode + let checkSet :: TeamFeatureStatusValue -> Int32 -> TestM () + checkSet stat tout = do + Util.putTeamFeatureFlagInternal @'Public.TeamFeatureSelfDeletingMessages + galley + tid + (setting stat tout) -- internal, public (/team/:tid/features), and team-agnostic (/feature-configs). - checkGet :: HasCallStack => TeamFeatureStatusValue -> Int32 -> Public.LockStatusValue -> TestM () - checkGet stat tout lockStatus = do - let expected = settingWithLockStatus stat tout lockStatus + checkGet :: HasCallStack => TeamFeatureStatusValue -> Int32 -> TestM () + checkGet stat tout = do + let expected = setting stat tout forM_ [ Util.getTeamFeatureFlagInternal Public.TeamFeatureSelfDeletingMessages tid, Util.getTeamFeatureFlagWithGalley Public.TeamFeatureSelfDeletingMessages galley owner tid, @@ -431,66 +413,30 @@ testSelfDeletingMessages = do ] (!!! responseJsonEither === const (Right expected)) - checkSetLockStatus :: HasCallStack => Public.LockStatusValue -> TestM () - checkSetLockStatus status = - do - Util.setLockStatusInternal @'Public.TeamFeatureSelfDeletingMessages galley tid status - !!! statusCode === const 200 - - -- test that the default lock status comes from `galley.yaml`. - -- use this to change `galley.integration.yaml` locally and manually test that conf file - -- parsing works as expected. - checkGet TeamFeatureEnabled 0 defLockStatus - - -- now don't worry about what's in the config, write something to cassandra, and test with that. - checkSetLockStatus Public.Locked - checkGet TeamFeatureEnabled 0 Public.Locked - checkSet TeamFeatureDisabled 0 409 - checkGet TeamFeatureEnabled 0 Public.Locked - checkSet TeamFeatureEnabled 30 409 - checkGet TeamFeatureEnabled 0 Public.Locked - checkSetLockStatus Public.Unlocked - checkGet TeamFeatureEnabled 0 Public.Unlocked - checkSet TeamFeatureDisabled 0 200 - checkGet TeamFeatureDisabled 0 Public.Unlocked - checkSet TeamFeatureEnabled 30 200 - checkGet TeamFeatureEnabled 30 Public.Unlocked - checkSet TeamFeatureDisabled 30 200 - checkGet TeamFeatureDisabled 30 Public.Unlocked - checkSetLockStatus Public.Locked - checkGet TeamFeatureEnabled 0 Public.Locked - checkSet TeamFeatureEnabled 50 409 - checkSetLockStatus Public.Unlocked - checkGet TeamFeatureDisabled 30 Public.Unlocked + checkGet TeamFeatureEnabled 0 + checkSet TeamFeatureDisabled 0 + checkGet TeamFeatureDisabled 0 + checkSet TeamFeatureEnabled 30 + checkGet TeamFeatureEnabled 30 -- | Call 'GET /teams/:tid/features' and 'GET /feature-configs', and check if all -- features are there. testAllFeatures :: TestM () testAllFeatures = do - defLockStatus :: Public.LockStatusValue <- - view - ( tsGConf - . optSettings - . setFeatureFlags - . flagSelfDeletingMessages - . unDefaults - . to Public.tfwcapsLockStatus - ) - (_owner, tid, member : _) <- Util.createBindingTeamWithNMembers 1 Util.getAllTeamFeatures member tid !!! do statusCode === const 200 - responseJsonMaybe === const (Just (expected TeamFeatureEnabled defLockStatus {- determined by default in galley -})) + responseJsonMaybe === const (Just (expected TeamFeatureEnabled {- determined by default in galley -})) Util.getAllTeamFeaturesPersonal member !!! do statusCode === const 200 - responseJsonMaybe === const (Just (expected TeamFeatureEnabled defLockStatus {- determined by default in galley -})) + responseJsonMaybe === const (Just (expected TeamFeatureEnabled {- determined by default in galley -})) randomPersonalUser <- Util.randomUser Util.getAllTeamFeaturesPersonal randomPersonalUser !!! do statusCode === const 200 - responseJsonMaybe === const (Just (expected TeamFeatureEnabled defLockStatus {- determined by 'getAfcConferenceCallingDefNew' in brig -})) + responseJsonMaybe === const (Just (expected TeamFeatureEnabled {- determined by 'getAfcConferenceCallingDefNew' in brig -})) where - expected confCalling lockState = + expected confCalling = object [ toS TeamFeatureLegalHold .= Public.TeamFeatureStatusNoConfig TeamFeatureDisabled, toS TeamFeatureSSO .= Public.TeamFeatureStatusNoConfig TeamFeatureDisabled, @@ -509,10 +455,10 @@ testAllFeatures = do toS TeamFeatureConferenceCalling .= Public.TeamFeatureStatusNoConfig confCalling, toS TeamFeatureSelfDeletingMessages - .= Public.TeamFeatureStatusWithConfigAndLockStatus @Public.TeamFeatureSelfDeletingMessagesConfig - TeamFeatureEnabled - (Public.TeamFeatureSelfDeletingMessagesConfig 0) - lockState + .= ( Public.TeamFeatureStatusWithConfig @Public.TeamFeatureSelfDeletingMessagesConfig + TeamFeatureEnabled + (Public.TeamFeatureSelfDeletingMessagesConfig 0) + ) ] toS :: TeamFeatureName -> Text toS = TE.decodeUtf8 . toByteString' @@ -532,6 +478,8 @@ testFeatureConfigConsistency = do unless (allTeamFeaturesRes `Set.isSubsetOf` allFeaturesRes) $ liftIO $ expectationFailure (show allTeamFeaturesRes <> " is not a subset of " <> show allFeaturesRes) + + pure () where parseObjectKeys :: ResponseLBS -> TestM (Set.Set Text) parseObjectKeys res = do @@ -552,11 +500,11 @@ assertFlagForbidden res = do fmap label . responseJsonMaybe === const (Just "no-team-member") assertFlagNoConfig :: - forall (ps :: Public.IncludeLockStatus) (a :: Public.TeamFeatureName). + forall (a :: Public.TeamFeatureName). ( HasCallStack, Typeable a, - Public.FeatureHasNoConfig ps a, - FromJSON (Public.TeamFeatureStatus 'Public.WithoutLockStatus a), + Public.FeatureHasNoConfig a, + FromJSON (Public.TeamFeatureStatus a), Public.KnownTeamFeatureName a ) => TestM ResponseLBS -> @@ -566,7 +514,7 @@ assertFlagNoConfig res expected = do res !!! do statusCode === const 200 ( fmap Public.tfwoStatus - . responseJsonEither @(Public.TeamFeatureStatus ps a) + . responseJsonEither @(Public.TeamFeatureStatus a) ) === const (Right expected) diff --git a/services/galley/test/integration/API/Teams/LegalHold.hs b/services/galley/test/integration/API/Teams/LegalHold.hs index d44974b5f73..7ccefd4ea6a 100644 --- a/services/galley/test/integration/API/Teams/LegalHold.hs +++ b/services/galley/test/integration/API/Teams/LegalHold.hs @@ -566,14 +566,14 @@ testEnablePerTeam = withTeam $ \owner tid -> do addTeamMemberInternal tid member (rolePermissions RoleMember) Nothing ensureQueueEmpty do - status :: Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureLegalHold <- responseJsonUnsafe <$> (getEnabled tid (getEnabled tid (getEnabled tid (getEnabled tid do @@ -585,7 +585,7 @@ testEnablePerTeam = withTeam $ \owner tid -> do liftIO $ assertEqual "User legal hold status should be enabled" UserLegalHoldEnabled status do putEnabled' id tid Public.TeamFeatureDisabled !!! testResponse 403 (Just "legalhold-whitelisted-only") - status :: Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureLegalHold <- responseJsonUnsafe <$> (getEnabled tid (getEnabled tid (getEnabled tid (getEnabled tid (getEnabled tid (getEnabled tid do @@ -554,7 +554,7 @@ testEnablePerTeam = do liftIO $ assertEqual "User legal hold status should be enabled" UserLegalHoldEnabled status do putEnabled tid Public.TeamFeatureDisabled -- disable again - status :: Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureLegalHold <- responseJsonUnsafe <$> (getEnabled tid (getEnabled tid (getEnabled tid (getEnabled tid (getEnabled tid (getEnabled tid (MonadIO m, MonadHttp m) => m () putTeamSearchVisibilityAvailableInternal g tid statusValue = - void $ - putTeamFeatureFlagInternalWithGalleyAndMod - @'Public.WithoutLockStatus - @'Public.TeamFeatureSearchVisibility - g - expect2xx - tid - (Public.TeamFeatureStatusNoConfig statusValue) + putTeamFeatureFlagInternalWithGalleyAndMod + @'Public.TeamFeatureSearchVisibility + g + expect2xx + tid + (Public.TeamFeatureStatusNoConfig statusValue) putLegalHoldEnabledInternal' :: HasCallStack => @@ -67,7 +65,7 @@ putLegalHoldEnabledInternal' :: Public.TeamFeatureStatusValue -> TestM () putLegalHoldEnabledInternal' g tid statusValue = - void $ putTeamFeatureFlagInternal @'Public.WithoutLockStatus @'Public.TeamFeatureLegalHold g tid (Public.TeamFeatureStatusNoConfig statusValue) + putTeamFeatureFlagInternal @'Public.TeamFeatureLegalHold g tid (Public.TeamFeatureStatusNoConfig statusValue) -------------------------------------------------------------------------------- @@ -151,52 +149,35 @@ getAllFeatureConfigsWithGalley galley uid = do . zUser uid putTeamFeatureFlagInternal :: - forall (ps :: Public.IncludeLockStatus) (a :: Public.TeamFeatureName). + forall (a :: Public.TeamFeatureName). ( HasCallStack, Public.KnownTeamFeatureName a, - ToJSON (Public.TeamFeatureStatus ps a) + ToJSON (Public.TeamFeatureStatus a) ) => (Request -> Request) -> TeamId -> - Public.TeamFeatureStatus ps a -> - TestM ResponseLBS + (Public.TeamFeatureStatus a) -> + TestM () putTeamFeatureFlagInternal reqmod tid status = do g <- view tsGalley - putTeamFeatureFlagInternalWithGalleyAndMod @ps @a g reqmod tid status + putTeamFeatureFlagInternalWithGalleyAndMod @a g reqmod tid status putTeamFeatureFlagInternalWithGalleyAndMod :: - forall (ps :: Public.IncludeLockStatus) (a :: Public.TeamFeatureName) m. + forall (a :: Public.TeamFeatureName) m. ( MonadIO m, MonadHttp m, HasCallStack, Public.KnownTeamFeatureName a, - ToJSON (Public.TeamFeatureStatus ps a) + ToJSON (Public.TeamFeatureStatus a) ) => (Request -> Request) -> (Request -> Request) -> TeamId -> - Public.TeamFeatureStatus ps a -> - m ResponseLBS + (Public.TeamFeatureStatus a) -> + m () putTeamFeatureFlagInternalWithGalleyAndMod galley reqmod tid status = - put $ + void . put $ galley . paths ["i", "teams", toByteString' tid, "features", toByteString' (Public.knownTeamFeatureName @a)] . json status . reqmod - -setLockStatusInternal :: - forall (a :: Public.TeamFeatureName). - ( HasCallStack, - Public.KnownTeamFeatureName a, - ToJSON Public.LockStatusValue - ) => - (Request -> Request) -> - TeamId -> - Public.LockStatusValue -> - TestM ResponseLBS -setLockStatusInternal reqmod tid lockStatus = do - galley <- view tsGalley - put $ - galley - . paths ["i", "teams", toByteString' tid, "features", toByteString' (Public.knownTeamFeatureName @a), toByteString' lockStatus] - . reqmod diff --git a/services/spar/src/Spar/Intra/Galley.hs b/services/spar/src/Spar/Intra/Galley.hs index f4984b2b059..d8a0bc6291c 100644 --- a/services/spar/src/Spar/Intra/Galley.hs +++ b/services/spar/src/Spar/Intra/Galley.hs @@ -31,13 +31,7 @@ import Imports import Network.HTTP.Types.Method import Spar.Error import qualified System.Logger.Class as Log -import Wire.API.Team.Feature - ( IncludeLockStatus (..), - TeamFeatureName (..), - TeamFeatureStatus, - TeamFeatureStatusNoConfig (..), - TeamFeatureStatusValue (..), - ) +import Wire.API.Team.Feature (TeamFeatureName (..), TeamFeatureStatus, TeamFeatureStatusNoConfig (..), TeamFeatureStatusValue (..)) ---------------------------------------------------------------------- @@ -94,7 +88,7 @@ isEmailValidationEnabledTeam tid = do resp <- call $ method GET . paths ["i", "teams", toByteString' tid, "features", "validateSAMLemails"] pure ( (statusCode resp == 200) - && ( responseJsonMaybe @(TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureValidateSAMLEmails) resp + && ( responseJsonMaybe @(TeamFeatureStatus 'TeamFeatureValidateSAMLEmails) resp == Just (TeamFeatureStatusNoConfig TeamFeatureEnabled) ) ) diff --git a/tools/stern/src/Stern/API.hs b/tools/stern/src/Stern/API.hs index ead623edff2..27e8e727098 100644 --- a/tools/stern/src/Stern/API.hs +++ b/tools/stern/src/Stern/API.hs @@ -594,25 +594,25 @@ getTeamAdminInfo = liftM (json . toAdminInfo) . Intra.getTeamInfo getTeamFeatureFlagH :: forall (a :: Public.TeamFeatureName). ( Public.KnownTeamFeatureName a, - FromJSON (Public.TeamFeatureStatus 'Public.WithoutLockStatus a), - ToJSON (Public.TeamFeatureStatus 'Public.WithoutLockStatus a), - Typeable (Public.TeamFeatureStatus 'Public.WithoutLockStatus a) + FromJSON (Public.TeamFeatureStatus a), + ToJSON (Public.TeamFeatureStatus a), + Typeable (Public.TeamFeatureStatus a) ) => TeamId -> Handler Response getTeamFeatureFlagH tid = - json <$> Intra.getTeamFeatureFlag @'Public.WithoutLockStatus @a tid + json <$> Intra.getTeamFeatureFlag @a tid setTeamFeatureFlagH :: forall (a :: Public.TeamFeatureName). ( Public.KnownTeamFeatureName a, - FromJSON (Public.TeamFeatureStatus 'Public.WithoutLockStatus a), - ToJSON (Public.TeamFeatureStatus 'Public.WithoutLockStatus a) + FromJSON (Public.TeamFeatureStatus a), + ToJSON (Public.TeamFeatureStatus a) ) => - TeamId ::: JsonRequest (Public.TeamFeatureStatus 'Public.WithoutLockStatus a) ::: JSON -> + TeamId ::: JsonRequest (Public.TeamFeatureStatus a) ::: JSON -> Handler Response setTeamFeatureFlagH (tid ::: req ::: _) = do - status :: Public.TeamFeatureStatus 'Public.WithoutLockStatus a <- parseBody req !>> mkError status400 "client-error" + status :: Public.TeamFeatureStatus a <- parseBody req !>> mkError status400 "client-error" empty <$ Intra.setTeamFeatureFlag @a tid status getTeamFeatureFlagNoConfigH :: @@ -755,9 +755,9 @@ noSuchUser = ifNothing (mkError status404 "no-user" "No such user") mkFeaturePutGetRoute :: forall (a :: Public.TeamFeatureName). ( Public.KnownTeamFeatureName a, - FromJSON (Public.TeamFeatureStatus 'Public.WithoutLockStatus a), - ToJSON (Public.TeamFeatureStatus 'Public.WithoutLockStatus a), - Typeable (Public.TeamFeatureStatus 'Public.WithoutLockStatus a) + FromJSON (Public.TeamFeatureStatus a), + ToJSON (Public.TeamFeatureStatus a), + Typeable (Public.TeamFeatureStatus a) ) => Routes Doc.ApiBuilder Handler () mkFeaturePutGetRoute = do @@ -774,7 +774,7 @@ mkFeaturePutGetRoute = do put ("/teams/:tid/features/" <> toByteString' featureName) (continue (setTeamFeatureFlagH @a)) $ capture "tid" - .&. jsonRequest @(Public.TeamFeatureStatus 'Public.WithoutLockStatus a) + .&. jsonRequest @(Public.TeamFeatureStatus a) .&. accept "application" "json" document "PUT" "setTeamFeatureFlag" $ do summary "Disable / enable feature flag for a given team" diff --git a/tools/stern/src/Stern/Intra.hs b/tools/stern/src/Stern/Intra.hs index 2139f16750e..e930aa76e03 100644 --- a/tools/stern/src/Stern/Intra.hs +++ b/tools/stern/src/Stern/Intra.hs @@ -452,13 +452,13 @@ setBlacklistStatus status emailOrPhone = do statusToMethod True = POST getTeamFeatureFlag :: - forall (ps :: Public.IncludeLockStatus) (a :: Public.TeamFeatureName). + forall (a :: Public.TeamFeatureName). ( Public.KnownTeamFeatureName a, - Typeable (Public.TeamFeatureStatus ps a), - FromJSON (Public.TeamFeatureStatus ps a) + Typeable (Public.TeamFeatureStatus a), + FromJSON (Public.TeamFeatureStatus a) ) => TeamId -> - Handler (Public.TeamFeatureStatus ps a) + Handler (Public.TeamFeatureStatus a) getTeamFeatureFlag tid = do info $ msg "Getting team feature status" gly <- view galley @@ -467,17 +467,17 @@ getTeamFeatureFlag tid = do . paths ["/i/teams", toByteString' tid, "features", toByteString' (Public.knownTeamFeatureName @a)] resp <- catchRpcErrors $ rpc' "galley" gly req case Bilge.statusCode resp of - 200 -> pure $ responseJsonUnsafe @(Public.TeamFeatureStatus ps a) resp + 200 -> pure $ responseJsonUnsafe @(Public.TeamFeatureStatus a) resp 404 -> throwE (mkError status404 "bad-upstream" "team doesnt exist") _ -> throwE (mkError status502 "bad-upstream" "bad response") setTeamFeatureFlag :: forall (a :: Public.TeamFeatureName). ( Public.KnownTeamFeatureName a, - ToJSON (Public.TeamFeatureStatus 'Public.WithoutLockStatus a) + ToJSON (Public.TeamFeatureStatus a) ) => TeamId -> - Public.TeamFeatureStatus 'Public.WithoutLockStatus a -> + Public.TeamFeatureStatus a -> Handler () setTeamFeatureFlag tid status = do info $ msg "Setting team feature status" From dfb18b6658cda6802cb4c6178c81a5534bfcb741 Mon Sep 17 00:00:00 2001 From: fisx Date: Mon, 29 Nov 2021 12:00:39 +0100 Subject: [PATCH 14/28] Fix docs. (#1941) --- changelog.d/4-docs/fix-docs | 1 + docs/reference/provisioning/scim-via-curl.md | 10 ++++------ 2 files changed, 5 insertions(+), 6 deletions(-) create mode 100644 changelog.d/4-docs/fix-docs diff --git a/changelog.d/4-docs/fix-docs b/changelog.d/4-docs/fix-docs new file mode 100644 index 00000000000..7cc610b9110 --- /dev/null +++ b/changelog.d/4-docs/fix-docs @@ -0,0 +1 @@ +Remove documentation of unsupported scim end-point use case. \ No newline at end of file diff --git a/docs/reference/provisioning/scim-via-curl.md b/docs/reference/provisioning/scim-via-curl.md index 2b64e425f4b..c39fd9ec6ae 100644 --- a/docs/reference/provisioning/scim-via-curl.md +++ b/docs/reference/provisioning/scim-via-curl.md @@ -159,12 +159,10 @@ curl -X GET \ ### get all users -```bash -curl -X GET \ - --header "Authorization: Bearer $SCIM_TOKEN" \ - --header 'Content-Type: application/json;charset=utf-8' \ - $WIRE_BACKEND/scim/v2/Users/ -``` +There is a way to do this in the SCIM protocol, but it's not +implemented in wire for performance reasons. If you need a complete +list of your team members, try the CSV download button in the team +management app. ### update user From 70cf97027a35bd44f7b59a52dc1f4bbb5f08a5ab Mon Sep 17 00:00:00 2001 From: fisx Date: Mon, 29 Nov 2021 14:22:39 +0100 Subject: [PATCH 15/28] Fix typo in cabal file. (#1942) --- services/galley/galley.cabal | 4 ++-- services/galley/package.yaml | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index b1f68193ca3..12da3f35501 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 955ba4e571c8a43aab5b78d001425cbc40f17e59b95bfabb8ab5d42bae6500b5 +-- hash: 3186b74c21301ff760ffae6e280c4e15ee9d184c18aaaf106251cc8edc821c03 name: galley version: 0.83.0 @@ -465,7 +465,7 @@ executable galley-schema ld-options: -static default-language: Haskell2010 -test-suite galley-types-tests +test-suite galley-tests type: exitcode-stdio-1.0 main-is: Main.hs other-modules: diff --git a/services/galley/package.yaml b/services/galley/package.yaml index c97f956613d..bf8e5ee19eb 100644 --- a/services/galley/package.yaml +++ b/services/galley/package.yaml @@ -105,7 +105,7 @@ library: - warp >=3.0 tests: - galley-types-tests: + galley-tests: main: Main.hs source-dirs: test/unit ghc-options: From 98e45669b559aa774b7b83e6daf020e1d70fb3ae Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Mon, 29 Nov 2021 18:42:10 +0100 Subject: [PATCH 16/28] Disable automatic creation of indices --- charts/elasticsearch-ephemeral/templates/es.yaml | 2 ++ 1 file changed, 2 insertions(+) diff --git a/charts/elasticsearch-ephemeral/templates/es.yaml b/charts/elasticsearch-ephemeral/templates/es.yaml index 9c9f00fca9f..1da1b217845 100644 --- a/charts/elasticsearch-ephemeral/templates/es.yaml +++ b/charts/elasticsearch-ephemeral/templates/es.yaml @@ -31,6 +31,8 @@ spec: value: "false" - name: "discovery.type" value: "single-node" + - name: "action.auto_create_index" + value: ".watches,.triggered_watches,.watcher-history-*" ports: - containerPort: 9200 name: http From 31b1ea1ff2297507f4d6756e27507955e1df820f Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Mon, 29 Nov 2021 19:05:06 +0100 Subject: [PATCH 17/28] add changelog --- .../3-bug-fixes/elasticsearch-ephemeral-disable-auto-creation | 1 + 1 file changed, 1 insertion(+) create mode 100644 changelog.d/3-bug-fixes/elasticsearch-ephemeral-disable-auto-creation diff --git a/changelog.d/3-bug-fixes/elasticsearch-ephemeral-disable-auto-creation b/changelog.d/3-bug-fixes/elasticsearch-ephemeral-disable-auto-creation new file mode 100644 index 00000000000..b0189061d78 --- /dev/null +++ b/changelog.d/3-bug-fixes/elasticsearch-ephemeral-disable-auto-creation @@ -0,0 +1 @@ +elasticsearch-ephemeral: Disable automatic creation of indices From f5c3f3f3e2cc8d3f8f18d3683473dd0e208eefb7 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Tue, 30 Nov 2021 18:25:49 +0100 Subject: [PATCH 18/28] Add note about manual action required to ugprade fake-aws-s3 (#1947) Co-authored-by: jschaul --- changelog.d/0-release-notes/minio-helm | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/changelog.d/0-release-notes/minio-helm b/changelog.d/0-release-notes/minio-helm index 248b77797f7..ff40a316260 100644 --- a/changelog.d/0-release-notes/minio-helm +++ b/changelog.d/0-release-notes/minio-helm @@ -1 +1,3 @@ -Breaking change to the `fake-aws-s3` helm chart. We now use minio helm chart from https://charts.min.io. The options are documented here: https://github.com/minio/minio/tree/master/helm/minio \ No newline at end of file +Breaking change to the `fake-aws-s3` (part of `fake-aws`) helm chart. We now use minio helm chart from https://charts.min.io. The options are documented [here](https://github.com/minio/minio/tree/master/helm/minio) (#1944) + +Before running the upgrade, the operators must use `kubectl edit deployment fake-aws-s3` and explicitly set `spec.template.spec.containers[0].serviceAccount` and `spec.template.spec.containers[0].serviceAccountName` to null. \ No newline at end of file From f992c7d8f711d1f5f7d5790c9d5808abda3009cd Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Wed, 1 Dec 2021 12:14:10 +0100 Subject: [PATCH 19/28] Add new LogFormat: StructuredJSON (#1951) This format is intended as an improvement over the JSON format. It tries to improve in these ways: - Explicitly encode log level as a key in the main JSON object logged - Encode field values as key-value pairs in the main JSON object Encoding logs like this makes it easy for external tools like fluent-bit and elasticsearch to understand the log level and the fields and index them as such without requiring bonanza to be present while processing logs. --- changelog.d/2-features/structured-json-logs | 1 + libs/extended/extended.cabal | 3 +- libs/extended/package.yaml | 7 ++-- libs/extended/src/System/Logger/Extended.hs | 43 ++++++++++++++++++++- 4 files changed, 48 insertions(+), 6 deletions(-) create mode 100644 changelog.d/2-features/structured-json-logs diff --git a/changelog.d/2-features/structured-json-logs b/changelog.d/2-features/structured-json-logs new file mode 100644 index 00000000000..841489cc6d0 --- /dev/null +++ b/changelog.d/2-features/structured-json-logs @@ -0,0 +1 @@ +Add log format called 'StructuredJSON' for easier log aggregation \ No newline at end of file diff --git a/libs/extended/extended.cabal b/libs/extended/extended.cabal index 4c7304bccc2..ca3ecbf67b7 100644 --- a/libs/extended/extended.cabal +++ b/libs/extended/extended.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 65015665656bc1ae721971ef3e88ed707aa7a2be02ba04cf4aab39ac6188714a +-- hash: 040115252374cb428a08ab286b9a4eb9492a407e9197009e7944f163dc1bfdcc name: extended version: 0.1.0 @@ -37,6 +37,7 @@ library , base , bytestring , cassandra-util + , containers , errors , exceptions , extra diff --git a/libs/extended/package.yaml b/libs/extended/package.yaml index aa4cdd43ab9..7714754d508 100644 --- a/libs/extended/package.yaml +++ b/libs/extended/package.yaml @@ -14,15 +14,16 @@ maintainer: Wire Swiss GmbH copyright: (c) 2018 Wire Swiss GmbH license: AGPL-3 dependencies: +- aeson - base - bytestring +- cassandra-util +- containers +- exceptions - extra -- aeson - imports - optparse-applicative - tinylog -- exceptions -- cassandra-util # for servant's 'ReqBodyCustomError' type defined here. - errors diff --git a/libs/extended/src/System/Logger/Extended.hs b/libs/extended/src/System/Logger/Extended.hs index 4c9787ee26b..26ba7b4a3ae 100644 --- a/libs/extended/src/System/Logger/Extended.hs +++ b/libs/extended/src/System/Logger/Extended.hs @@ -33,10 +33,11 @@ where import Cassandra (MonadClient) import Control.Monad.Catch -import Data.Aeson +import Data.Aeson as Aeson import Data.Aeson.Encoding (list, pair, text) import qualified Data.ByteString.Lazy.Builder as B import qualified Data.ByteString.Lazy.Char8 as L +import qualified Data.Map.Lazy as Map import Data.String.Conversions (cs) import GHC.Generics import Imports @@ -50,7 +51,7 @@ instance FromJSON LC.Level instance ToJSON LC.Level -- | The log formats supported -data LogFormat = JSON | Plain | Netstring +data LogFormat = JSON | Plain | Netstring | StructuredJSON deriving stock (Eq, Show, Generic) deriving anyclass (ToJSON, FromJSON) @@ -77,6 +78,43 @@ collect = foldr go (Element' mempty []) jsonRenderer :: Renderer jsonRenderer _sep _dateFormat _logLevel = fromEncoding . elementToEncoding . collect +data StructuredJSONOutput = StructuredJSONOutput {msgs :: [Text], fields :: Map Text [Text]} + +-- | Displays all the 'Bytes' segments in a list under key @msgs@ and 'Field' +-- segments as key-value pair in a JSON +-- +-- >>> logElems = [Bytes "I", Bytes "The message", Field "field1" "val1", Field "field2" "val2", Field "field1" "val1.1"] +-- >>> B.toLazyByteString $ structuredJSONRenderer "," iso8601UTC Info logElems +-- "{\"msgs\":[\"I\",\"The message\"],\"field1\":[\"val1\",\"val1.1\"],\"field2\":\"val2\",\"level\":\"Info\"}" +structuredJSONRenderer :: Renderer +structuredJSONRenderer _sep _dateFmt lvl logElems = + let structuredJSON = toStructuredJSONOutput logElems + in fromEncoding . toEncoding $ + object + ( [ "level" Aeson..= lvl, + "msgs" Aeson..= msgs structuredJSON + ] + <> Map.foldMapWithKey (\k v -> [k Aeson..= renderTextList v]) (fields structuredJSON) + ) + where + -- Renders List of Text as a String, if it only contains one element. This + -- should be most (if not all) of the cases + renderTextList :: [Text] -> Value + renderTextList [t] = String t + renderTextList xs = toJSON xs + + builderToText :: Builder -> Text + builderToText = cs . eval + + toStructuredJSONOutput :: [Element] -> StructuredJSONOutput + toStructuredJSONOutput = + foldr + ( \e o -> case e of + Bytes b -> o {msgs = builderToText b : msgs o} + Field k v -> o {fields = Map.insertWith (<>) (builderToText k) (map builderToText [v]) (fields o)} + ) + (StructuredJSONOutput mempty mempty) + -- | Here for backwards-compatibility reasons netStringsToLogFormat :: Bool -> LogFormat netStringsToLogFormat True = Netstring @@ -124,6 +162,7 @@ simpleSettings lvl logFormat = Netstring -> \_separator _dateFormat _level -> Log.renderNetstr Plain -> \separator _dateFormat _level -> Log.renderDefault separator JSON -> jsonRenderer + StructuredJSON -> structuredJSONRenderer -- | Replace all whitespace characters in the output of a renderer by @' '@. -- Log output must be ASCII encoding. From 5b902bdd40577d6e3902f52b818726d13c5136a2 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Wed, 1 Dec 2021 12:16:14 +0100 Subject: [PATCH 20/28] Upgrade kibana and fluent-bit helm charts (#1952) * charts/kibana: Use helm chart from Elastic and auto-configure index-patterns * charts/elasticsearch-ephemeral: Bump default version to 6.8.18 This is required for oldest maintained kibana helm chart to work. * charts/fluent-bit: Use chart from Fluent and configure appropriately This chart is much more opaque than the unmaintained chart, so whole config has to be written as multi-line strings. Default for `inputs` and `filters` seems to be fine, but the `outputs` and `customParsers` need to be configured * Makefile: Also serve and publish kibana and fluent-bit charts --- Makefile | 4 +- changelog.d/2-features/elasticsearch | 1 + changelog.d/2-features/fluent-bit | 1 + changelog.d/2-features/kibana | 1 + charts/elasticsearch-ephemeral/values.yaml | 2 +- charts/fluent-bit/requirements.yaml | 4 +- charts/fluent-bit/values.yaml | 48 +++++++++++++++---- charts/kibana/requirements.yaml | 4 +- .../kibana/templates/basic-auth-secret.yaml | 13 +++++ charts/kibana/values.yaml | 31 ++++++++---- 10 files changed, 82 insertions(+), 27 deletions(-) create mode 100644 changelog.d/2-features/elasticsearch create mode 100644 changelog.d/2-features/fluent-bit create mode 100644 changelog.d/2-features/kibana create mode 100644 charts/kibana/templates/basic-auth-secret.yaml diff --git a/Makefile b/Makefile index 2bfa7e61fa1..09682269744 100644 --- a/Makefile +++ b/Makefile @@ -8,13 +8,13 @@ DOCKER_TAG ?= $(USER) # default helm chart version must be 0.0.42 for local development (because 42 is the answer to the universe and everything) HELM_SEMVER ?= 0.0.42 # The list of helm charts needed for integration tests on kubernetes -CHARTS_INTEGRATION := wire-server databases-ephemeral fake-aws nginx-ingress-controller nginx-ingress-services wire-server-metrics +CHARTS_INTEGRATION := wire-server databases-ephemeral fake-aws nginx-ingress-controller nginx-ingress-services wire-server-metrics fluent-bit kibana # The list of helm charts to publish on S3 # FUTUREWORK: after we "inline local subcharts", # (e.g. move charts/brig to charts/wire-server/brig) # this list could be generated from the folder names under ./charts/ like so: # CHARTS_RELEASE := $(shell find charts/ -maxdepth 1 -type d | xargs -n 1 basename | grep -v charts) -CHARTS_RELEASE := wire-server redis-ephemeral databases-ephemeral fake-aws fake-aws-s3 fake-aws-sqs aws-ingress fluent-bit kibana backoffice calling-test demo-smtp elasticsearch-curator elasticsearch-external elasticsearch-ephemeral fluent-bit minio-external cassandra-external nginx-ingress-controller nginx-ingress-services reaper wire-server-metrics sftd +CHARTS_RELEASE := wire-server redis-ephemeral databases-ephemeral fake-aws fake-aws-s3 fake-aws-sqs aws-ingress fluent-bit kibana backoffice calling-test demo-smtp elasticsearch-curator elasticsearch-external elasticsearch-ephemeral minio-external cassandra-external nginx-ingress-controller nginx-ingress-services reaper wire-server-metrics sftd BUILDAH_PUSH ?= 0 KIND_CLUSTER_NAME := wire-server BUILDAH_KIND_LOAD ?= 1 diff --git a/changelog.d/2-features/elasticsearch b/changelog.d/2-features/elasticsearch new file mode 100644 index 00000000000..d2d463ce624 --- /dev/null +++ b/changelog.d/2-features/elasticsearch @@ -0,0 +1 @@ +By default install elasticsearch version 6.8.18 when using the elasticsearch-ephemeral chart \ No newline at end of file diff --git a/changelog.d/2-features/fluent-bit b/changelog.d/2-features/fluent-bit new file mode 100644 index 00000000000..8c379fea833 --- /dev/null +++ b/changelog.d/2-features/fluent-bit @@ -0,0 +1 @@ +Use fluent-bit chart from fluent.github.io instead of deprecated charts.helm.sh. Previous fluent-bit values are not compatible with the new chart, the documentation for the new chart can be found [here](https://github.com/fluent/helm-charts/tree/main/charts/fluent-bit) \ No newline at end of file diff --git a/changelog.d/2-features/kibana b/changelog.d/2-features/kibana new file mode 100644 index 00000000000..1b718f01e3e --- /dev/null +++ b/changelog.d/2-features/kibana @@ -0,0 +1 @@ +Use kibana chart from helm.elastic.co instead of deprecated charts.helm.sh. Previous kibana values are not compatible with the new chart, the documentation for the new chart can be found [here](https://github.com/elastic/helm-charts/tree/main/kibana). This also upgrades kibana to version 6.8.18. diff --git a/charts/elasticsearch-ephemeral/values.yaml b/charts/elasticsearch-ephemeral/values.yaml index 55dd63fd80c..13100a3b40b 100644 --- a/charts/elasticsearch-ephemeral/values.yaml +++ b/charts/elasticsearch-ephemeral/values.yaml @@ -1,6 +1,6 @@ image: repository: elasticsearch - tag: 6.7.1 + tag: 6.8.18 service: httpPort: 9200 diff --git a/charts/fluent-bit/requirements.yaml b/charts/fluent-bit/requirements.yaml index 53ec618bdff..096b844d3d8 100644 --- a/charts/fluent-bit/requirements.yaml +++ b/charts/fluent-bit/requirements.yaml @@ -1,4 +1,4 @@ dependencies: - name: fluent-bit - version: 2.7.0 - repository: https://charts.helm.sh/stable + version: 0.19.6 + repository: https://fluent.github.io/helm-charts diff --git a/charts/fluent-bit/values.yaml b/charts/fluent-bit/values.yaml index 2a31dcf2707..b73a28e190d 100644 --- a/charts/fluent-bit/values.yaml +++ b/charts/fluent-bit/values.yaml @@ -1,11 +1,39 @@ -# See defaults in https://github.com/helm/charts/tree/master/stable/fluent-bit +# See defaults in https://github.com/fluent/helm-charts/tree/main/charts/fluent-bit fluent-bit: - backend: - type: es - es: - host: elasticsearch-ephemeral - parsers: - enabled: true - regex: - - name: nginz - regex: '^(?[^ ]*) (?[^ ]*) "(?[0-9\/a-zA-Z:]* [+][0-9]*)" "(?.*)" (?[0-9]*) (?[0-9]*) "(?[^ ])" "(?.*)" (?[^ ]*) (?[^ ]*) (?[^ ]*) (?[^ ]*) (?[^ ]*) (?[^ ]*) (?[^ ]*) (?[a-z0-9]*)' + config: + outputs: | + [OUTPUT] + Name es + Match kube.* + Host elasticsearch-ephemeral + Generate_ID On + Logstash_Format On + Logstash_Prefix pod + Retry_Limit False + Trace_Error On + Replace_Dots On + [OUTPUT] + Name es + Match host.* + Host elasticsearch-ephemeral + Generate_ID On + Logstash_Format On + Logstash_Prefix node + Retry_Limit False + Trace_Error On + Replace_Dots On + ## https://docs.fluentbit.io/manual/pipeline/parsers + customParsers: | + [PARSER] + Name docker_no_time + Format json + Time_Keep Off + Time_Key time + Time_Format %Y-%m-%dT%H:%M:%S.%L + + [PARSER] + Name nginz + Format regex + Regex ^(?[^ ]*) (?[^ ]*) "(?[0-9\/a-zA-Z:]* [+][0-9]*)" "(?[^ ]*) (?.*) (?.*)" (?[0-9]*) (?[0-9]*) "(?[^ ])" "(?.*)" (?[^ ]*) (?[^ ]*) (?[^ ]*) (?[^ ]*) (?[^ ]*) (?[^ ]*) (?[^ ]*) (?[a-z0-9]*) + Time_Key thetime + Time_Format %d/%b/%Y:%H:%M:%S %z diff --git a/charts/kibana/requirements.yaml b/charts/kibana/requirements.yaml index d925f22883d..53ccd8b99bb 100644 --- a/charts/kibana/requirements.yaml +++ b/charts/kibana/requirements.yaml @@ -1,4 +1,4 @@ dependencies: - name: kibana - version: 2.2.0 - repository: https://charts.helm.sh/stable + version: 6.8.18 + repository: https://helm.elastic.co diff --git a/charts/kibana/templates/basic-auth-secret.yaml b/charts/kibana/templates/basic-auth-secret.yaml new file mode 100644 index 00000000000..fef8ca38041 --- /dev/null +++ b/charts/kibana/templates/basic-auth-secret.yaml @@ -0,0 +1,13 @@ +{{- if (hasKey .Values "basicAuthSecret") }} +apiVersion: v1 +kind: Secret +metadata: + name: kibana-basic-auth + labels: + chart: {{ .Chart.Name }}-{{ .Chart.Version | replace "+" "_" }} + release: "{{ .Release.Name }}" + heritage: "{{ .Release.Service }}" +type: Opaque +data: + auth: {{ .Values.basicAuthSecret | b64enc | quote }} +{{- end }} diff --git a/charts/kibana/values.yaml b/charts/kibana/values.yaml index 86bd5feae96..41789450124 100644 --- a/charts/kibana/values.yaml +++ b/charts/kibana/values.yaml @@ -1,11 +1,22 @@ -# See defaults in https://github.com/helm/charts/tree/master/stable/kibana +## When this is configured, a secret called kibana-basic-auth is created with key +## `auth` and value of this key. +# basicAuthSecret: + +# See defaults in https://github.com/elastic/helm-charts/tree/main/kibana kibana: - env: - # All Kibana configuration options are adjustable via env vars. - # To adjust a config option to an env var uppercase + replace `.` with `_` - # Ref: https://www.elastic.co/guide/en/kibana/current/settings.html - # - ELASTICSEARCH_URL: http://elasticsearch-ephemeral:9200 - files: - kibana.yml: - elasticsearch.url: http://elasticsearch-ephemeral:9200 + elasticsearchHosts: "http://elasticsearch-ephemeral:9200" + + lifecycle: + postStart: + exec: + command: + - bash + - -c + - | + #!/bin/bash + KB_URL=http://localhost:5601 + # Wait for kibana to be ready + while [[ "$(curl -s -o /dev/null -w '%{http_code}\n' -L $KB_URL)" != "200" ]]; do sleep 1; done + # Import index patterns for pods logs and node logs, for kibana <7, + # we have to use the dashboard import API. + curl -XPOST "$KB_URL/api/kibana/dashboards/import" -H "Content-Type: application/json" -H 'kbn-xsrf: true' -d'{"objects":[{"type": "index-pattern", "id": "7e7061cc-7d7e-4287-b631-a7c5257f73e5", "attributes": {"title": "pod-*", "timeFieldName": "@timestamp"}},{"type": "index-pattern", "id": "b1a2866f-70ec-40fb-bfea-d78e9662b741", "attributes": {"title": "node-*", "timeFieldName": "@timestamp"}}]}' From 41902818522d6c2bb25125b1761f14cb250a062d Mon Sep 17 00:00:00 2001 From: fisx Date: Wed, 1 Dec 2021 16:10:56 +0100 Subject: [PATCH 21/28] Enrich haddocks with cross-references. (#1945) --- services/brig/src/Brig/Options.hs | 1 + services/galley/src/Galley/API/CustomBackend.hs | 1 + 2 files changed, 2 insertions(+) diff --git a/services/brig/src/Brig/Options.hs b/services/brig/src/Brig/Options.hs index 7710b7608ef..7725bb515ab 100644 --- a/services/brig/src/Brig/Options.hs +++ b/services/brig/src/Brig/Options.hs @@ -604,6 +604,7 @@ data CustomerExtensions = CustomerExtensions } deriving (Show, FromJSON, Generic) +-- | See also: "Galley.API.CustomBackend", `galley.custom_backend`. newtype DomainsBlockedForRegistration = DomainsBlockedForRegistration [Domain] deriving newtype (Show, FromJSON, Generic) diff --git a/services/galley/src/Galley/API/CustomBackend.hs b/services/galley/src/Galley/API/CustomBackend.hs index ebcff2b55e2..d65c6effe62 100644 --- a/services/galley/src/Galley/API/CustomBackend.hs +++ b/services/galley/src/Galley/API/CustomBackend.hs @@ -15,6 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . +-- | See also: 'DomainsBlockedForRegistration'. module Galley.API.CustomBackend ( getCustomBackendByDomainH, internalPutCustomBackendByDomainH, From 30dc9350ea45af7fa05ef0df142086f0a151e7b2 Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Wed, 1 Dec 2021 16:53:07 +0100 Subject: [PATCH 22/28] Replace gRPC with HTTP2 in federator (#1930) * Change federation API to be based on HTTP2 This is a preliminary commit that removes gRPC completely from wire-api-federation, and assumes that federator is going to be accepting and forwarding HTTP2 requests directly. Failures are going to be propagated using normal HTTP error codes, and using Wai.Error values as responses. The federation API is still following the same conventions as before, with the exception that now we require that every endpoint consists of a single path segment, which is the name of the RPC. For this reason, the `on-user-deleted` endpoints in brig and galley have been updated to single-segment endpoints. - Removed gRPC dependency. - Removed explicit "/federation" prefix from federation APIs. - `clientRoutes` is now a polymorphic value that works for both services. - Brig and Galley API modules can now be imported without clashes. - Federator client has been completely rewritten, and now implements HTTP2 client functionality on top of the http2 library. The low-level http2 client functionality that establishes a connection supports both plaintext and TLS, and will also be used to implement the outward service of federator. - Federator client errors have been restructured and documented. They are organised into three layers: low-level connection/TLS errors, federator client errors, and high-level errors thrown by the application code. - The origin domain header type in Servant is now a special combinator that works just like a header on the server side, but is removed from the resulting client type. Federator client knows to add the origin domain header on every request, whether or not the origin domain is present in the API type. * Rewrite federator services as HTTP applications This is a re-implementation of the inward and outward federator services as simple Wai applications, with the following interface: * federation client / outward service path /rpc/:domain/:component/:rpc * inward ingress path /federation/:component/:rpc The origin domain is passed as a header directly in the form expected by the federation API in brig and galley (i.e. a `Wire-Origin-Domain` header). Server-to-server authentication is not affected, and the client certificate is received by the inward service as a header, exacly as it was before. - Removed gRPC dependency. - Both the inward and outward services are now simple Wai applications that serve a single route each, and forward the request appropriately, without looking at the body. - Removed error layer from the main application monad. - Renamed `LookupError` to `DiscoveryFailure` for consistency. - All polysemy error effects are now converted to Wai responses with a JSON `Wai.Error` as body. - Restored and simplified the federator mock server. Its functionality is similar to before the change, but the gRPC type for federated requests has been replaced by a simpler custom type `FederatedRequest`, which is used only by the mock machinery itself. - The internal Polysemy effects used in federator have been re-organised slightly. For example, the `Remote` effect never fails by itself, and `RemoteError` can be thrown by its interpretation, instead. Also, error handling and logging is performed in a single place (`Federator.Response`) for both services. - The canonical `Remote` effect interpretation is now using the low-level HTTP2 client functionality of Federator client to forward requests to a remote federator. - Validation has been simplified. In particular, path sanitisation has been removed, since the RPC path is now a normal HTTP path, which is assumed to have already been validated and sanitised by the HTTP server (and probably all the intermediate proxies and load balancers). - The federator client tests that were residing in wire-api-federation before have now been moved to the federator package, since they depend on the mock federator code. * Brig: follow changes in federator Adapted brig to the changes in federator and the corresponding mock machinery. This is mostly about following type changes, and installing the federation API at its correct "/federation" prefix, since the prefix has now been removed from the Servant API types. * Galley: follow changes in federator Adapted galley to the changes in federator and the corresponding mock machinery. This is mostly about following type changes, and installing the federation API at its correct "/federation" prefix, since the prefix has now been removed from the Servant API types. * Replace gRPC with HTTP in ingress configuration * Makefile improvements * Add CHANGELOG entry * Follow http2 upstream preface-race branch * HTTP2 client: test parsing of response header * Remove all remaining mentions of gRPC - Delete obsolete python federation client - Delete out-of-date federation documentation - Change mentions of gRPC to HTTP2 where appropriate * Restore federation-not-available label * Turn all immediate federator errors into 403 * Map remote federator error responses When the remote federator returns an error response, fail by returning a 533 error which is specific for this situation. This makes it possible to distinguish local and remote federation failures, and makes sure that a 5xx error is always returned for remote ones. * Convert local 403 federator errors to 500 If the local federator returns 403, that indicates an issue in federator itself, or in the communication between the service making a federated call and the local federator. This should result in a 500 status code. * remove commented-out code * ExternalServer enforces RPC name format Co-authored-by: Paolo Capriotti --- Makefile | 2 +- cabal.project | 18 +- cabal.project.freeze | 18 +- changelog.d/6-federation/drop-grpc | 1 + charts/federator/templates/configmap.yaml | 2 +- .../templates/ingress_federator.yaml | 11 +- deploy/services-demo/conf/nginz/nginx.conf | 12 +- direnv.nix | 2 +- docs/developer/federation-api-conventions.md | 18 +- docs/developer/how-to.md | 12 + docs/reference/federation/README.md | 3 - .../img/remote_user_handle_lookup.png | Bin 69045 -> 0 bytes ...remote_user_handle_lookup.swimlanes.io.txt | 21 - ...tial_federation_request_across_backends.md | 30 -- hack/bin/cabal-run-tests.sh | 6 +- hack/federation/grpcurlhandle.sh | 46 -- hack/federation/python-client/.gitignore | 3 - hack/federation/python-client/README.md | 43 -- hack/federation/python-client/client.py | 29 -- hack/federation/python-client/poetry.lock | 403 ---------------- hack/federation/python-client/pyproject.toml | 16 - .../src/Network/Wai/Utilities/Server.hs | 18 +- libs/wire-api-federation/package.yaml | 18 +- .../src/Wire/API/Federation/API.hs | 45 ++ .../src/Wire/API/Federation/API/Brig.hs | 37 +- .../src/Wire/API/Federation/API/Galley.hs | 37 +- .../src/Wire/API/Federation/Client.hs | 375 +++++++++------ .../{GRPC/Helper.hs => Component.hs} | 48 +- .../src/Wire/API/Federation/Domain.hs | 28 +- .../src/Wire/API/Federation/Error.hs | 262 ++++++---- .../src/Wire/API/Federation/GRPC/Client.hs | 61 --- .../src/Wire/API/Federation/GRPC/Types.hs | 211 -------- .../src/Wire/API/Federation/Mock.hs | 165 ------- .../Test/Wire/API/Federation/ClientSpec.hs | 104 ---- .../Wire/API/Federation/GRPC/TypesSpec.hs | 86 ---- .../wire-api-federation.cabal | 41 +- services/brig/brig.cabal | 7 +- services/brig/package.yaml | 4 +- services/brig/src/Brig/API/Client.hs | 2 +- services/brig/src/Brig/API/Error.hs | 1 - services/brig/src/Brig/API/Federation.hs | 32 +- services/brig/src/Brig/API/Types.hs | 2 +- services/brig/src/Brig/API/User.hs | 2 +- services/brig/src/Brig/App.hs | 5 - services/brig/src/Brig/Federation/Client.hs | 27 +- services/brig/src/Brig/IO/Intra.hs | 3 +- services/brig/src/Brig/Run.hs | 8 +- .../brig/test/integration/API/Federation.hs | 32 +- services/brig/test/integration/API/Search.hs | 3 +- .../brig/test/integration/API/User/Account.hs | 36 +- .../test/integration/API/User/Connection.hs | 4 +- .../brig/test/integration/API/User/Util.hs | 23 +- .../test/integration/Federation/End2end.hs | 2 +- .../brig/test/integration/Federation/Util.hs | 43 +- services/brig/test/integration/Main.hs | 34 +- services/brig/test/integration/Util.hs | 23 +- services/brig/test/unit/Main.hs | 2 - .../brig/test/unit/Test/Brig/API/Error.hs | 113 ----- services/federator/federator.cabal | 88 ++-- services/federator/federator.integration.yaml | 2 +- services/federator/package.yaml | 35 +- services/federator/src/Federator/App.hs | 22 +- services/federator/src/Federator/Discovery.hs | 43 +- services/federator/src/Federator/Env.hs | 2 +- .../src/Federator/Error.hs} | 27 +- .../src/Federator/Error/ServerError.hs | 45 ++ .../federator/src/Federator/ExternalServer.hs | 198 ++++---- .../federator/src/Federator/InternalServer.hs | 189 ++++---- .../federator/src/Federator/MockServer.hs | 175 +++++++ services/federator/src/Federator/Remote.hs | 204 ++++---- services/federator/src/Federator/Response.hs | 136 ++++++ services/federator/src/Federator/Run.hs | 10 +- services/federator/src/Federator/Service.hs | 21 +- .../Federator/Utils/PolysemyServerError.hs | 38 -- .../federator/src/Federator/Validation.hs | 183 ++++--- .../integration/Test/Federator/IngressSpec.hs | 179 ++++--- .../integration/Test/Federator/InwardSpec.hs | 136 +++--- .../test/integration/Test/Federator/Util.hs | 55 +-- services/federator/test/unit/Main.hs | 10 +- .../test/unit/Test/Federator/Client.hs | 186 ++++++++ .../unit/Test/Federator/ExternalServer.hs | 287 +++++++++-- .../unit/Test/Federator/InternalServer.hs | 214 +++------ .../test/unit/Test/Federator/Remote.hs | 152 +++--- .../test/unit/Test/Federator/Response.hs | 91 ++++ .../test/unit/Test/Federator/Util.hs | 73 +++ .../test/unit/Test/Federator/Validation.hs | 261 ++++------ services/galley/galley.cabal | 5 +- services/galley/package.yaml | 2 +- services/galley/src/Galley/API/Action.hs | 5 +- services/galley/src/Galley/API/Create.hs | 2 +- services/galley/src/Galley/API/Error.hs | 1 - services/galley/src/Galley/API/Federation.hs | 12 +- services/galley/src/Galley/API/Internal.hs | 12 +- services/galley/src/Galley/API/LegalHold.hs | 2 +- services/galley/src/Galley/API/Message.hs | 45 +- services/galley/src/Galley/API/Query.hs | 19 +- services/galley/src/Galley/API/Teams.hs | 2 +- .../galley/src/Galley/API/Teams/Features.hs | 2 +- services/galley/src/Galley/API/Update.hs | 23 +- services/galley/src/Galley/API/Util.hs | 7 +- .../src/Galley/Effects/FederatorAccess.hs | 25 +- services/galley/src/Galley/Intra/Federator.hs | 37 +- services/galley/src/Galley/Monad.hs | 6 - services/galley/src/Galley/Run.hs | 12 +- services/galley/test/integration/API.hs | 450 +++++++++--------- .../galley/test/integration/API/Federation.hs | 76 +-- .../test/integration/API/MessageTimer.hs | 12 +- services/galley/test/integration/API/Roles.hs | 28 +- services/galley/test/integration/API/Util.hs | 180 ++++--- services/galley/test/integration/TestSetup.hs | 29 +- stack.yaml | 39 +- stack.yaml.lock | 139 +----- tools/convert-to-cabal/README.md | 1 + 113 files changed, 3115 insertions(+), 3760 deletions(-) create mode 100644 changelog.d/6-federation/drop-grpc delete mode 100644 docs/reference/federation/README.md delete mode 100644 docs/reference/federation/img/remote_user_handle_lookup.png delete mode 100644 docs/reference/federation/img/remote_user_handle_lookup.swimlanes.io.txt delete mode 100644 docs/reference/federation/pull-requests/1319_initial_federation_request_across_backends.md delete mode 100755 hack/federation/grpcurlhandle.sh delete mode 100644 hack/federation/python-client/.gitignore delete mode 100644 hack/federation/python-client/README.md delete mode 100644 hack/federation/python-client/client.py delete mode 100644 hack/federation/python-client/poetry.lock delete mode 100644 hack/federation/python-client/pyproject.toml create mode 100644 libs/wire-api-federation/src/Wire/API/Federation/API.hs rename libs/wire-api-federation/src/Wire/API/Federation/{GRPC/Helper.hs => Component.hs} (54%) delete mode 100644 libs/wire-api-federation/src/Wire/API/Federation/GRPC/Client.hs delete mode 100644 libs/wire-api-federation/src/Wire/API/Federation/GRPC/Types.hs delete mode 100644 libs/wire-api-federation/src/Wire/API/Federation/Mock.hs delete mode 100644 libs/wire-api-federation/test/Test/Wire/API/Federation/ClientSpec.hs delete mode 100644 libs/wire-api-federation/test/Test/Wire/API/Federation/GRPC/TypesSpec.hs delete mode 100644 services/brig/test/unit/Test/Brig/API/Error.hs rename services/{galley/src/Galley/Intra/Federator/Types.hs => federator/src/Federator/Error.hs} (59%) create mode 100644 services/federator/src/Federator/Error/ServerError.hs create mode 100644 services/federator/src/Federator/MockServer.hs create mode 100644 services/federator/src/Federator/Response.hs delete mode 100644 services/federator/src/Federator/Utils/PolysemyServerError.hs create mode 100644 services/federator/test/unit/Test/Federator/Client.hs create mode 100644 services/federator/test/unit/Test/Federator/Response.hs create mode 100644 services/federator/test/unit/Test/Federator/Util.hs diff --git a/Makefile b/Makefile index 09682269744..a2015eba6fc 100644 --- a/Makefile +++ b/Makefile @@ -61,7 +61,7 @@ endif c: cabal build $(WIRE_CABAL_BUILD_OPTIONS) $(package) ifeq ($(test), 1) - ./hack/bin/cabal-run-tests.sh $(package) + ./hack/bin/cabal-run-tests.sh $(package) $(testargs) endif ./hack/bin/cabal-install-artefacts.sh $(package) diff --git a/cabal.project b/cabal.project index b27da7ad1c5..35f93fb1000 100644 --- a/cabal.project +++ b/cabal.project @@ -79,11 +79,6 @@ source-repository-package location: https://github.com/kim/snappy-framing tag: d99f702c0086729efd6848dea8a01e5266c3a61c -source-repository-package - type: git - location: https://github.com/lucasdicioccio/http2-client - tag: 73f5975e18eda9d071aa5548fcea6b5a51e61769 - source-repository-package type: git location: https://github.com/vincenthz/hs-certificate @@ -140,18 +135,7 @@ source-repository-package source-repository-package type: git location: https://github.com/wireapp/http2 - tag: 7c465be1201e0945b106f7cc6176ac1b1193be13 - -source-repository-package - type: git - location: https://github.com/wireapp/http2-grpc-haskell - tag: eea98418672626eafbace3181ca34bf44bee91c0 - subdir: http2-client-grpc - -source-repository-package - type: git - location: https://github.com/wireapp/polysemy-mocks - tag: 8f687140a218ec8cc9e466259600d3c5839ed185 + tag: 1ee1ce432d923839dab6782410e91dc17df2a880 source-repository-package type: git diff --git a/cabal.project.freeze b/cabal.project.freeze index bd2b1ba22d1..22013305b8f 100644 --- a/cabal.project.freeze +++ b/cabal.project.freeze @@ -487,7 +487,6 @@ constraints: any.AC-Angle ==1.0, any.commutative ==0.0.2, any.comonad ==5.0.6, any.compactmap ==0.1.4.2.1, - any.compendium-client ==0.2.1.1, any.compensated ==0.8.1, any.compiler-warnings ==0.1.0, any.composable-associations ==0.1.0.0, @@ -1138,8 +1137,6 @@ constraints: any.AC-Angle ==1.0, any.http-reverse-proxy ==0.6.0, any.http-streams ==0.8.7.2, any.http-types ==0.12.3, - any.http2-grpc-proto3-wire ==0.1.0.0, - any.http2-grpc-types ==0.5.0.0, any.httpd-shed ==0.4.1.1, any.human-readable-duration ==0.2.1.4, any.hunit-dejafu ==2.0.0.4, @@ -1489,14 +1486,6 @@ constraints: any.AC-Angle ==1.0, any.mpi-hs-cereal ==0.1.0.0, any.mtl-compat ==0.2.2, any.mtl-prelude ==2.0.3.1, - any.mu-avro ==0.4.0.4, - any.mu-grpc-client ==0.4.0.1, - any.mu-grpc-common ==0.4.0.0, - any.mu-grpc-server ==0.4.0.0, - any.mu-optics ==0.3.0.1, - any.mu-protobuf ==0.4.2.0, - any.mu-rpc ==0.4.0.1, - any.mu-schema ==0.3.1.2, any.multi-containers ==0.1.1, any.multiarg ==0.30.0.10, any.multimap ==1.2.1, @@ -1619,7 +1608,6 @@ constraints: any.AC-Angle ==1.0, any.papillon ==0.1.1.1, any.parallel ==3.2.2.0, any.parallel-io ==0.3.3, - any.parameterized ==0.5.0.0, any.paripari ==0.6.0.1, any.parseargs ==0.2.0.9, any.parsec-class ==1.0.0.0, @@ -1703,6 +1691,7 @@ constraints: any.AC-Angle ==1.0, any.polyparse ==1.13, any.polysemy ==1.7.0.0, any.polysemy-check ==0.8.1.0, + any.polysemy-mocks ==0.2.0.0, any.polysemy-plugin ==0.4.2.0, any.pooled-io ==0.0.2.2, any.port-utils ==0.2.1.0, @@ -1761,7 +1750,7 @@ constraints: any.AC-Angle ==1.0, any.proto-lens-protoc ==0.7.0.0, any.proto-lens-runtime ==0.7.0.0, any.proto-lens-setup ==0.4.0.4, - any.proto3-wire ==1.2.0, + any.proto3-wire ==1.1.0, any.protobuf ==0.2.1.3, any.protobuf-simple ==0.1.1.0, any.protocol-radius ==0.0.1.1, @@ -2415,8 +2404,7 @@ constraints: any.AC-Angle ==1.0, any.wai-session ==0.3.3, any.wai-slack-middleware ==0.2.0, any.wai-websockets ==3.0.1.2, - any.warp ==3.3.13, - any.warp-grpc ==0.4.0.1, + any.warp ==3.3.17, any.warp-tls ==3.2.12, any.warp-tls-uid ==0.2.0.6, any.wave ==0.2.0, diff --git a/changelog.d/6-federation/drop-grpc b/changelog.d/6-federation/drop-grpc new file mode 100644 index 00000000000..2160c8b6a8f --- /dev/null +++ b/changelog.d/6-federation/drop-grpc @@ -0,0 +1 @@ +The server-to-server API now uses HTTP2 directly instead of gRPC diff --git a/charts/federator/templates/configmap.yaml b/charts/federator/templates/configmap.yaml index da4623a738e..1c151172e81 100644 --- a/charts/federator/templates/configmap.yaml +++ b/charts/federator/templates/configmap.yaml @@ -41,7 +41,7 @@ data: {{- with .optSettings }} optSettings: # Filepath to one or more PEM-encoded server certificates to use as a trust - # store when making grpc requests to remote backends + # store when making requests to remote backends {{- if $.Values.remoteCAContents }} remoteCAStore: "/etc/wire/federator/ca/ca.crt" {{- end }} diff --git a/charts/nginx-ingress-services/templates/ingress_federator.yaml b/charts/nginx-ingress-services/templates/ingress_federator.yaml index 946fcab7e48..e756d1cee24 100644 --- a/charts/nginx-ingress-services/templates/ingress_federator.yaml +++ b/charts/nginx-ingress-services/templates/ingress_federator.yaml @@ -1,9 +1,6 @@ {{- if .Values.federator.enabled }} -# We use a separate ingress for federator/grpc since we can't forward -# both normal http1 traffic and grpc traffic in the same kubernetes ingress it appears. -# Setting backend-protocol annotation to "GRPC" for everything is likely incorrect. -# see also example https://github.com/kubernetes/ingress-nginx/blob/master/docs/examples/grpc/ingress.yaml -# and docs https://kubernetes.github.io/ingress-nginx/examples/grpc/ +# We use a separate ingress for federator so that we can require client +# certificates only for federation requests apiVersion: extensions/v1beta1 kind: Ingress metadata: @@ -11,12 +8,12 @@ metadata: annotations: kubernetes.io/ingress.class: "nginx" nginx.ingress.kubernetes.io/ssl-redirect: "true" - nginx.ingress.kubernetes.io/backend-protocol: "GRPC" + nginx.ingress.kubernetes.io/backend-protocol: "HTTP" nginx.ingress.kubernetes.io/auth-tls-verify-client: "on" nginx.ingress.kubernetes.io/auth-tls-verify-depth: "{{ .Values.tls.verify_depth }}" nginx.ingress.kubernetes.io/auth-tls-secret: "{{ .Release.Namespace }}/federator-ca-secret" nginx.ingress.kubernetes.io/configuration-snippet: | - grpc_set_header "X-SSL-Certificate" $ssl_client_escaped_cert; + proxy_set_header "X-SSL-Certificate" $ssl_client_escaped_cert; spec: tls: - hosts: diff --git a/deploy/services-demo/conf/nginz/nginx.conf b/deploy/services-demo/conf/nginz/nginx.conf index 62e6ce5685f..aa85a7cca58 100644 --- a/deploy/services-demo/conf/nginz/nginx.conf +++ b/deploy/services-demo/conf/nginz/nginx.conf @@ -113,7 +113,7 @@ http { # for nginx-without-tls, we need to use a separate port for http2 traffic, # as nginx cannot handle unencrypted http1 and http2 trafic on the same # port. - # This port is only used for trying out nginx grpc forwarding without TLS locally and should not + # This port is only used for trying out nginx http2 forwarding without TLS locally and should not # be ported to any production nginz config. listen 8090 http2; @@ -160,15 +160,13 @@ http { # Service Routing # - # Federator endpoints: expose the federatorExternal port (Inward grpc - # service) - location /wire.federator.Inward { + # Federator endpoints: expose the federatorExternal port (Inward service) + location /federation { set $sanitized_request $request; zauth off; - grpc_set_header "X-SSL-Certificate" $ssl_client_escaped_cert; - - grpc_pass grpc://federator_external; + proxy_set_header "X-SSL-Certificate" $ssl_client_escaped_cert; + proxy_pass http://federator_external; # FUTUREWORK(federation): are any other settings # (e.g. timeouts, body size, buffers, headers,...) diff --git a/direnv.nix b/direnv.nix index 65fb8cada9d..f99ef759825 100644 --- a/direnv.nix +++ b/direnv.nix @@ -164,7 +164,6 @@ in pkgs.buildEnv { pkgs.cfssl pkgs.docker-compose pkgs.gnumake - pkgs.grpcurl pkgs.haskell-language-server pkgs.jq pkgs.ormolu @@ -172,6 +171,7 @@ in pkgs.buildEnv { pkgs.wget pkgs.yq pkgs.rsync + pkgs.netcat # To actually run buildah on nixos, I had to follow this: https://gist.github.com/alexhrescale/474d55635154e6b2cd6362c3bb403faf pkgs.buildah diff --git a/docs/developer/federation-api-conventions.md b/docs/developer/federation-api-conventions.md index 5703ffe3af5..84b73a8a6c0 100644 --- a/docs/developer/federation-api-conventions.md +++ b/docs/developer/federation-api-conventions.md @@ -3,11 +3,11 @@ # Federation API Conventions - All endpoints must start with `/federation/` -- All path segments must be in kebab-case. The name the field in the record must - be the same name in camelCase. -- There can be either one or two path segments after `/federation/`, so - `/federation/foo` is valid, `/fedeartion/foo/bar` is valid, but - `/federation/foo/bar/baz` is not. +- All path segments must be in kebab-case, and only consist of alphanumeric + characters. The name the field in the record must be the same name in + camelCase. +- There must be exactly one segment after `/federation/`, so + `/federation/foo` is valid, but `/federation/foo/bar` is not. - All endpoints must be `POST`. - No query query params or captured path params, all information that needs to go must go in body. @@ -20,7 +20,7 @@ the content type of the body. - Ensure that paths don't collide between brig and galley federation API, this will be very helpful when we merge brig and galley. -- Name of the first path segment after `/federation/` must be either +- The name of the path segment after `/federation/` must be either `-` or `on--`, e.g. `get-conversations` or `on-conversation-created`. @@ -33,9 +33,3 @@ this request has authority on, like a conversation got created, or a message is sent, then use the second format like `on-conversation-created` or `on-message-sent` -- Path segment number 3 (so `/federation/not-this/but-this-one`), must only be - used in exceptional circumstances, like when there needs to be the same path - in brig and galley, e.g. `on-user-deleted`. In this case use the third segment - to express the difference. For `on-user-deleted` we came up with - `on-user-deleted/connections`for brig and `on-user-deleted/conversations` for - galley. diff --git a/docs/developer/how-to.md b/docs/developer/how-to.md index aa2a42b7f89..f259039cf9e 100644 --- a/docs/developer/how-to.md +++ b/docs/developer/how-to.md @@ -183,6 +183,18 @@ Note that this runs your *locally* compiled `brig-integration`, so this allows t 2. recompile: `make -C services/brig fast` 3. run `./services/brig/federation-tests.sh test-$USER` again. +### Run selected integration tests on kuberentes + +To run selective tests from brig-integration: + +``` +helm -n $NAMESPACE get hooks $NAMESPACE-wire-server | yq '.' | jq -r 'select(.metadata.name | contains("brig-integration"))' > /tmp/integration-pod + +# optional: edit the test pattern /tmp/integration-pod + +kubectl apply -n $NAMESPACE -f /tmp/integration-pod +``` + ## 4 Teardown To destroy all the resources on the kubernetes cluster that have been created run diff --git a/docs/reference/federation/README.md b/docs/reference/federation/README.md deleted file mode 100644 index 99e321d2b1a..00000000000 --- a/docs/reference/federation/README.md +++ /dev/null @@ -1,3 +0,0 @@ -# Federation - -This folder contains some developer reference documentation on federation. It's early days, and more documentation may be added here, or elsewhere as time goes on. diff --git a/docs/reference/federation/img/remote_user_handle_lookup.png b/docs/reference/federation/img/remote_user_handle_lookup.png deleted file mode 100644 index 13ca6b3f7bee1a452f0a8762bdbce5158f0c0469..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 69045 zcmeFZ2UO4hA3ypDsfeT~+IwgVQ5q>e&zd_ulMWqd_LCm9jtxi;JP(i*H9>wbsFji zbSV^SW(s9RKJ9A!4Rw;^Z~TkON%!DBO6FVk?-U9*MdN^qo?GHbm#ZFgTL;ZA$r3uT zH$f_@S3^pYucYv`SzlZjO z@b9IHqW`X`+~d8c-ji>9-E*n$Ge@{7Z zf2SaG@PAKIzwrOTH%hv`o@0;lp+jp=ojMgSW2LFF>!5|t(yX;(S!ZYGjn{`_MFnnh z?Q#BgHCI4NO1tys6Pyu9zA&C#EImF2lwxrPK~rXT)cQi zOYrLD%Tyyje~$mm>*=eD;yd?pm%Kb%MMXutqW7K$N0Y)k^6Xg(7k&>lNqbJ&zJF@S zQd3itot^D>`!?H7+fRPQ#R@NTHHLRPeGQu_?JV)kyMKE>*(m(UhOO(cJ3Y7x3JTOU zG%C^##W{R$6%adJ$o%fX;mY@qj(y1F+qP}(^k`RQiRW~-=d|4_YHA*S{#CiTxz*C`>(a04{`bVIlyV?ZEsfD(mp-C8#8n9(iY7b$G64)u3I&JmTX%^(-re|#OIN8k+vm@p%{%;3 zm_kk$xrpmW)D1NyS>PI)%jBGSbIakL1Ho zer{b@SO|G(;_mMLYieq9Oz`0A*!>Zld%0;>_{{&@rQox`S{uQ2u<7pJ9Q&S9^ACqJ z_Ik}^-@mO)zLFj{*^=L4`p3qyZU|%l?a#C8a`^Q{g;I_MT&pEaKG^rxwCJ{piHQx& z%>3QAy!xu>@XUKYi*x5*itzAI)z{ajpUB~*r>C!K3)K`pa%a!+;?r(FK0b}+^vj69 zb<2FLyX0GQ^2#e$u2fYCNA_4`Ys3iVUmRRRG3_e6q*?pOYjz@j=Y?A{3lEcg_PMyY zBzJTcxk{oIQ7BVWQ~6%AGL|x1D5eWD<2E0kY_aRizZ@C4VPSSC>DR=B=nF;BTME)z zTsOnRk7(>tv2ecRe)1?j-!f-7DSOLwU%!5hHuSRZE)KSCy8Ec4G&gr=P1qK`f|rx8 z0@kW#3MEPBI)87a_<2r`YSdWY=vlou7-zB%XPss}d*lQ!op0gtf(0n7;Jk=Pg^a9Ja6WdccG_bJNB!gWK>jDt+IN3Lj{+e zzxLPU_jfjJnH*wbVy5TLg=`i-74&2Cz}GjoS*1)VqQ^5Pi_6ZBPfo7fwQCn@W%;L1 ztREg5)PBmbSi3O7JlLGPzxl(5O|?Vo7#L_M3f^;i8`~@_EMh+%Pu%PE%AYP;rh0k_ z52}0p`c>GL?b;HNO!hF!nWe=&A%QLCOaDb?X8QvW$bRsHmu- z7bR`js9!$Te|qZG&yGB5LqkK2y{L?garja!d0E3*u4CQ%jE(Q!Uz+_r6gqhR;}b@Y zKf`GkPven1ii*bZ+pWXzJ$?FAFZ1C;p~O9xGzS&MjPkXcTUtc2PotRb)6@*H(kV#^Zq#*x^;AwQm)lo>xV8js&$*LgzsW@4h)`zI%#m%DuX@nh}nofo2? z#Kgu5%*@O%=Z6Ob1UU4*qE2&R9(tY}(&xVOY%71VRl`luJo~d}MHIYdw4d2|coa4l zx!T7jQO_pf5VGILT}+7ejQhQR6f3w7^=Pe8+ow+_X8I$P zZhS0q=)E%Ft;@{Dwry7Fx!bsT&PaWXQ1skbSJ6YgyuP7xC`r_u5u;s2YX=+R4BG8Z zpFVBYmU&v0(}b5dC4$NmkgUbGrlaIuh`frri%af(SDo33!B8XX{+jDSp`n%ej{Ou0 zlc1Kekr8`eUtiT-H7wvJlk@G*ta3ig?Ryo3=ge z?OT|HjvO#H<~;WyBVf%Y(V)Th_I9A45Zyc2D;3{bQmeBXY7^?3W`yg4+rH}HH(R9>wS%Q zC11rt=kF^xI5^@H5-Q%jIs7cVtW4?3)vHvLYuB!Q>nhqMcqB0h^=xHbQhjG_EzQZ3 zCq?s4zPH}bp|m*36wbMK&9P(0WY4`^14aS)byTZ`Zb`j%8m}U z>ukHOm6n!%Vw*dC|KY<_T(CY*oAc*GdG=p3o&45f-t--7VcL98WvqCe>X?U5UB~Cb zOXqWTB>{MSetABSbFW7b(^)GktK@?boN{Qzr+&K6P6!m2lvK|QjEzO~RtBE8H0jB` z(6Lj&?H6U|&Yd$~Z`*$v9hK5xs?8HzvIL} zeV+^-zYpc*guWg_^^+%J$-c`=(RZz}leCMxfpVBAw5XR%CLK5l6lGkyz*Co)^8(Fr z{{i@nQ7x_NGRabM*H0_2t>ME3asiEN2aKp2QL>U|eNe;ggakSi|F|0r ztWwHiCeP1YzpvHRq^8n6db|^jmuK(Z(|B*U*@-j)D03QHT6E4X{`%#>!_BQ6bp3j4 zvCrf;9gUKqw|8Q0lr1KlZ@nM9fr*Ll=F!_b59=-wG%3czqw=ih!si!JUSByCy@b(u zM(%hDABmSz5knP@o}_QAtJ^T#mL=))5vc3*fV9Muz`psrTmYLa4LEiDdt1;=1;&!D zUcDN5=Z^SImiPN}jwUJg{djY0N6h52&8yx_X}<@4#9kLJ_L|idQ}UjBaW5-NQewMf zUlnhJG$W&q#$Ph0NJlNej2$02Hoo)hh0khWhbQ+-aDf8JnT{ z{yl}++>3*nW{Y!w_64rzxbZpLx{0%XPFh-epSrsGiye8_kyqMX>TRg&^Jn;Y?4<@v z8I8V!nP^CTGB|(+qLQM?Gm7XY(;C8}-9CF~1*(q;-yzOaeXbvH6fJTdz7r?|+m zq31fR)xV$Md76Vou49`U{!C7W9Ct-6th!|I^M_q`@ky~|puiA?^#KCRJwpp_MNglfd82!37k2W+ zB?3Lo6Egf$`f{FXCtumX#g(P^P>?C)@GV&#_r^lkF$sxdkM+f48#XX9dTYsXu;X7B zy}Z2Eh}(DOOA8*oYh>!KtGjWtq_L4{K~fUeW(lJcPj>D_@up}$&`Q{6GT$sCBO_(g z%uT>Mm`;oOolT;81oul@)@`7@;%8ACt|7?h=;U-YGgAW8bQQO6E4^y0=<#SRmt#i9 z9%w~%x`?|D)G?0dcwGt46ADi^DtI`qVx;pLl z%y15QQ4R*mw-1k5c3$|rib9aLuC8uX$BhrkkG$J%lzPvH;ibhzS*ayc1`YBp(wTY&i8+&=4mNF^?m&#Beumpi-qO&p(&}U zs8$+Ah0b&>EiL&@L*XYLoO7e>o?RsyGQjlQ^30hPkveE@emMPH}E{<>)>E73O2X|F?-)5at}o6{Ta5QryG@O3xwf7o1lyk!+m^cA)$6wU1H@SLz6y}@ zo|DDHb<#99ty;Cp^w*aPG^&JrTgQzS!*22kLPAP!DcM#Hn{BZy%^rBsuj}qM_7bCAfkvbEq<@NMdhs+p+fMqNoE+LUYjE)7+ocRI^OV z)BpxZohx;j`DG?+)2zIBr-gfVCPI11GwJ5d)rSr>Y&^S`kuhoyQLa*s9swq);@s}x z;Q{SI8Se|^pZSp`d+UyKK`{(fH8rnVS{T8=UV(r+qIA4u3K2Sb*Z<+ehXXr=goM%t z)vj+1&`DKGzVzdxoWmEtQ?-@&vn$V^Z%4b;$uizcDUTL7M9A3nKU(Ko zQmBCzlP3$gY5T_Cx3s9BEbe$#k^-XkWH3}-qp3*O)rvd(rw(veC(B6(_xbO=^~=7DYs|@qIqzve{oA)SP;jbUaNN0k7Z@Q7#PZ87 zi`$PG>I9z#yo|0ndG}xH9s#k1uykDCR}flS@T=?a8#8 z-377sPoKB}IGU#|0F%dFmQ3$fVs3lW(6Hag$SCRu%ZJbpJw04}2g6rID#^ddNapQ6 z(pUOpRtJ2Lb$q;Ih?bGDr8bDjm~$hC?<$;R-?dFdgznhGBgfB|Kt|enh5HK*8im5b z!cxy-@8skJ+}4ji12AAw!W0252(&8J>IyfvxcFhOrDTsfku_`9Y~;dM%+nks$`we0 zz|YoI)!os(y}be9C#UTp#xZdP`unTfjl~`-RxJRx(5!dBYmetBoP7Lk|45NJ?}_8B z8QC44J!dXlxDEn=GQ!b!9xp(dP>Ko3t6QGxupevf+&JE5;u{=+-a2P&adq=SoVn^+ zV8r9@9pgn)-RGO{U5=kQtgfzn;>4$-9lD3HQQl{na6NeNz&ydLQAHJ52&gpU+Bn<=2U?qHS_&pQnu635sIId;C|3mfgd1x6*#+KqT~xkB_=+J znxgpOL=Jy^x|Un%`^Tq-yZ8kJM8sW}7Tm92IL6^UH_2H0OAC@B*b;w#FJ8b55Vr4k z#Z{VZACl#ECT1L%4E*F;-8426Q zDXUhm78P*tTNo%^=$t!YX=N20(Q~A4wEg+e)jzaT6B8S`lzf-iV+0RJdp$r))E_vY z8`A$;bSnGZyLVU1%F1Snf#`xlLUd0pgM^%mNIKD+>o+a0gr#ZDGEo|zy+XZ~|AIHv zMbvrGZeBZ_L!kK#+f*V*|VrGE{oPT^2Piv|NO5tZ36E5WgWFZD=;v}_wV0r+MfxWd!K&! z){gUiI0*S5y!VH~!1GaP`P;u{n^p4f?Pe|;k%X)|qNAT zYtT%uJ-2Ss+^7i9cP%zH*3$E_K~@b4GZlppSfGaHhewlEL})nLoIPuXnreeWYh3CT zoO&?g6<933Yj$2W!QtE2&^D^7s=lCbkd^_L!4DUQ8&W#ztDMKAa7{QzC|*6|rFcP55G|f&isRAz z?w#k@@BTn8pK>VRj?<&3`GtfCssA-O=?^uGtl*Kzw5Lz6gRyUt+n)y@X(^L1(}@BL z{)%0;>aK$O6)3f4Xe{RLc*z`WNJ=@LsGYoz`i8jSW+)w%gmWk;b>EDS4}#Em4{bO7 z)JsvUiGW53x_65A{FLfPI0SlqtI)HK`eA=ilquY+XlPhG7X=R84EoWQuCsqoCOJ8| zPln>pA@7oYeELhpRcgwsYwOsm+HhWYC>x;k9Q)#NN8a_OZB}*}#PPMjF(_iMTzk9? z1}4N$z1R>P6BC>J$c=sNJSmjzYGtb`tl4Y>{W_tsNSfBva+9LJ3i2(OInAu zw5l$>s;pdldZ(C}R`!b*V$Qx$Dgq>cS&eVr5CA#-dHM?BYEW!%z1~9{0v=IOO|R~JM+?W2 z^KF@Q05aQNtb2Lx!^VwFOadJZjg8C@WAwjyfVIDRb9b^aSwf8uW4r83{{kYZmt~kWXqTsr7}ph%sWn6^9NwJ3C*lUEzoNz-`-^ zuXDC!EsI1@16r$aY?6Yzu2|d0kDK4#kr%qT2q8AQ>29A%k;_m2t|HgaCTP5pj||33 zBvHRE|B_Cp7%3I6UhU)Sc#)G+G2UOB1Km5n zsHpPw>ou!auO{}x-1Jxk>W-#huFhm7gVH_hT;byx%n*5$)SK9V^bZ_7Xn}oX(|nH# zQgCus7K5j!=j3P?8;hiI6{yvY(ykP(1Q}}L&AfZa@H$SC!Q0#W#HmxS-o0Z&X{gDu zsO68jAp8u6IbpkXGpfJ|L&MN9d#JVo7CPrH_N=3)cL3*t{7!=lg&O1s4P5Z>Eq@%6 zRGjiYIj4|wAD;vtijyEJAtd6sh?{Tv{vIwl0Bk`j!Ia=h}T;rA72v%jW$e7D^Z`r8x5RorSB6aVq4 z)3q;OzRW7`B1XA~UMJ_X;6|5+kN0gcC-5J`yQNH7F#&v|_U-%83l9})2xv;H z-HQ?u~wf#p3lG$O|PH)u$!sY|PED5;p?uAWim|6^Z8dk4qwXq#n# zj*gDo1MUZkM@#O<6Sz0ty8$E_-@Mi_p)>vDyRXa6!{zOn;bXws;fOu%lm+enou2M>VWb5z<%Gx8TQw?}7B#VTBYK(8={0~y|RtQD6V z{>Q=kf8&wK@t>WYO$PWxs$sS*w;gpKjw_Fl5Dg{UriJ%~P0I>Y+vT>;$_D~&%ezV> zCMG(Jb{3dtH8|b+*8dVBsq@GuMyTQN(ca2`kcO;>=l8Zhx87>U!5DkLu1+0cffQs4 zzI}Y!A^#!A<>x7q0znTa4_IWm|KPzZ0LrDMrE248^gf#p8JoZ?=BQ4oCGmDe+m-vO zs;koy`x*6dd{q%tJJJk6Im`h7D1HDE_dq#q5L!6X7=Iai8NLOdynIpB=exIVg)}y5 zfdid=VQgYzLMgu~ZYX<7l5x|hchh$gi~wiLN5r7DwUs-j{>#9CKR919dWdENw3bwe zaVX&x=n}m{L(`>2%9BZxfNBeq?~Y;vsUmZr16d&2PB$44<}#uT6|lI$-`~3}hV3|@ z3z!9F&kn^j{25@Vvr`CGlNSmEH3SMjoHn%|U=KT&X8IY7@*Swg$H!qTAAncdoOXyM zzo0qXJ>x|3S34zgA)_kA^c@LG1#z*GILL;5$#vX zu2b&139W+X6upVpc!1gu{<%)(q0YG4P}jW=!6v04(-ZFtJ^ow!b0MHe5>;WBbD)6q zRuCm8^R#@u2T@y(99fT#wSklKt>o+hYIukHVaT1zwVgFC8$I85iyOAq=g$E>=@UR7 z)7{}l$cvyNQKUX@coZEM7YK>&2E0sS{h8|=+5dZo7{W}Mi z1*)%aLIovME{gBqy@wACMt%ka2KLu-`To6R507%m$;ol!+<>=`7!%<>xa!Gzk94E| z06lBNohLgJpeJ;*I83bdSyYM}iw95c7u8GmLx`#u7pd<&;2QJtqrI@k%5VFd14~mV zut&u~2CF+FK;PB^Nr5ljLlL!kpUwzd6-gKzhHH3sD$oEeEp0iV_FCJc=H|SFUt!C? zg2@lUFZwIaACE}J|Dz4Jaqac+hkkYsClf&v;*eJD4bNT|3tD+c=_Ie0sbj{{*=A~Y+wX*zV!87fj`=Z6*E7nGT!&oX%BK&pr~uH zel(CQ>w5sttE@<5;{AKQkxw}*NyG^b21yeUy1D&KWBEXR3<+RB|J3}<%E=iHE3Oi* zE;2hC`#Bg(9FhDYQm^vTg{F`^F%z5_#E+D5%vt~yv9FY$jiQo$862dB1*dgOmJUe> zy^ON#Jp;>mNAK(jpkoq5uwn}`6soqiVm=Gw2MJfr%*_1t`!`dTc&=U78ZIs_%B<^F zQlVN>R4Eg_#n4)4ii?ZCjEvBugy5j6blzQX$pG;-gT(+TjAWwz*@;n6qzF*eE%&O7 z-yD3ESx@x^lmah)6|optuz}$3+dd@4#s+}U5-%BSwF+MvG7i0-4|Ek zZx29bt9qsyy4eg{`9z7w4pKjn_VW7k!64l*PvRQ=mMaiM_+(|7eV1k*w)$WPZAPVF z-Eoc?mlM3}b-&7i*_&b~SHKfREi$W*7N~pkhFaUrh~%}vHBZzcO40&FD8H~!v(!R( z$-!gfleE@dg)OLnRS+Ubk8Is1Usb3JRrrQul@s^YO0Nd~q;|LG+W6N@7)TlY*rc zh&s)KU?Te%H)J1JgleZw-D;gXd-g2xdY0yXNXpuEvJ%b7cUjT-(uW_Bw-OV>h|vt~ z;MeqYAg<2GERzUaQjMFpyNFfV|>{;K!>~F#(&9H_GI(p3dIaFk$NR9@^U6r||F(2V_d&Hzl0+h$;^M`N&G@g*qn%qQ#qWmgey0RaB{J*Wt6$?zuF)3P&(;ujgjuMj|2T&U%dZsgjl9^r_seGRn^u~S^R7~PZl`kR3Y9DaX2%&zFgdh_N@ z^I~q^M>w8es)CtpI&#Iu#Kj3sxBZl@@+>T4xjzIDU&{8A6!45WB3I^F6;OEkK>b%o zE?=#OwnDx-KySKj=%Ys>f?Dx@kk!y^)L#>81s|MGLSntV>!^Qt`1;Se7aj-iSKeA~ zcy~uSN=m-lI4|_bv+yR90twP?mb@-qgYBk3iSu? z-CXMJDZQ-+n~2yr5HVO{Ze9faRoS<1#cBr5g(JbmsL5o5Ao}VDs!kyxPO#rfKdO~g zgSZs_BF7$3>KFtKb8Rai2Y&hbb+x3VByz3D-E3l&3re>EYHn`% z14)JE#oB}56Hp+@0rgwRF=7!r;fLU4G6V<$sO-xYuU%eA^9u3?g@_~O&=|5`z6=0I zfNK&&{!?Y;ei?~jc#lzN@90C75Y^%PsGT^$ib6Wgv!13!=&@13#hJMuSvd&XqRUdF zo2;M^l>v6_i5zok=S!D*fBXnVPa-%E`QVLZ{xsCo!FfObjP-CqbKU$yB4hn-7==%a z3UrH)pGAz5b+5;Z83m}1W@ctV!NJ5M>qT#aHkX1!*0($X3kA|CCsMsL*h$F`9|nSR zq(Fp<-(}B<<(SJ9294^J?ffKA*!~7DG z3)*CLVFdf`D?~jRe*dV?bu~0BX!(5z!$?U>Q{D3_UEvoK!-TA;-vaAS>$mKQir!lh zASKNk&OrFgjN8JP?=n;1$pl1l=_yl$V-moW3?* z2FA@V!G*tgrczxt}z!o#FMMLzNT%sK@Hg=`pH{DOj-KJiFZmCbx= zY@~%}qXt9}y0XP7HpnHBP)UJ8EKpRU>rZuulQ>rN9xTr_=)KNAKW_rdBmEK@ zE6{e;n5gH}2;iw=>HMfXWws>ScczyHnQInQ8`^d2ssYNhaV~L)`*6(rT)8MGa&5N& z&a9?1fBdM17R1VzJ|LZ(u7c7)Ljfovsxk81K+4L9xj1EFlMkqg`&oc4UkO*WH zE(6Ps^ptTyl#L$j>+g^KSVH2u!q@lSmvC>Qfjc<<5<&2^96g-z>e`7=Xn0|+p9L8o zoiQ`xQOtx)jks2jyAM~=;#iAY7R3oJS{eDG@jDgzVmv?vSZNfQXl0kESek&`L) zFbciA6d=$!&QDzcc~`HY94qd>m%fL2$N7(1GNVyBInpHYT^Y#GpX9q#0aX#cz`C`C zF@5+|1$%GnE<3T0$1{y~V_)nkTRM(uPnC$B6OjiR&(tfVER~mM>|o*Y7K}0 zDe|a}B=FA)DKF5NSGNMNaY4xr79+S6FG?k%Hyh$~HnA`te{zCx&z?PUuA}V0X%35X zmn%yNcVWqGs#A2m`TH%2Cy#Xq@>*ro96nZy?6dG0RO) zAPy5DTm<$HGfq8{k$ee%vhy!7pFx6`#6)0X5mwHwnXAZB}Im3!FC()<{S5Nn()xH!mPzfyH#i~i%|kFNp3f@iLT{iVN6v6zG5eJ}&4 zs@tF8O^{(I6f_TISe?>vnaCUf6q1cx6yd|?PCh-gW4v|);G>&|hdJme25TPm;;2>| zKLnNmR;Y%p3U6x-_j2vw>LUJrBt$s_2{=b!5lt@uoQMQG@!-B^A`_nZ?A53Xlo}g1BIRXA{VUqGa3mC{pYNEp-e)s7Q7c zlC=f0=Mb@lFU}&X0x4Q+Ax%k0=wR_T;o&3?q|_YI`XQ?K!y*&WHyj+eeD7W;Gp}w$ zU%))@2Ze%H64mFxJV_ufBYI3!Y%Db!8(TfYDzY>CU*of38w=Jv#qmWA3$YM~NT4$! za_L($5A78S#0G11_qWJ2ARYu_L&+uXp+W;WR3nY=dNlA9xD{k z49~fi?iNxg2vVegOeKLf<2P-pXSlOg){Xsy`)820XHB7g54bDR5=as6K}4t@r&F^5 zDjt=eoApfv&Mr)tOpo;(1Q>;$c@?haKIEuvLq#XJ4i8H6ii)lwo(5&W^&{BACV4B8 zfr7e^bfjc<>ExudMk5ce$m}XH<)!->*hMJSeyEh6>#M}Snkkd`eYD*Qw3t98fe2P_Apl2pH4?mi zS$+`hp=Va2)KD=i@`Q@QwfGzU!kiCumlWVxQjlY}8Dv9~N;705vQl=ol-S8V3U&STxD&w3&yScxkn?K*1IiTM_w0b~=z(8Prj0-j32 z86;{AK!X$>fUB8`Emr;6o_B>0S{&%&Y8?2P`LQw`oDq<#O^?Ij$fCji1wxoc0t9^W zDh>I3t71{Fd#t1(2xx*t}mNL zd1=*pC}UNaI||_#3sT&L?O5}xw^G`)oPzv5H3nZuZ9p0y93~L2W&vlARmn%8boMJ7 zs-Sw!QN4%jk7Jetq0~@B#tE^+fJYUofj|RkdN3YI)Cw(92dge?-)&SZ_#L?yL{I_| zHXZo-wGZD=(%EFozr6*nsTm}*6WOLz_}u7y_hnB82L{rdYsr;}PJ(k$ zv*Gr!+0&1FJ6>6^EQzV`b19LGb7m0ehXX@SkpiR3MxN*cv=2~ZO+y4 zruDkVI;pGC>ai4(E)8w1t^0s(apF=x`io`Ib1JYRV!t1sK|j+d7*Gsiz{&3h>fB`y z2LO+IM@GVc%=;l+VmgFzId~dcA5I}CnrNOCS|}8pROmi%pej&=82awTY=bF zRAi(dK0-e(jhxe0dIS=`fTK{a-Fy!Pn^ne=7FY^t@9>k)&zO+PNOpgEZp{FIRn4{5+so@0auFm{fOdXBU;k#SR;cQS zU3uF$W0e<;n3LIsM++yF) zBh+S3ctr1}WY&Y^g#oBkmX}l3ZWb%YAFJC_24B25ymJwO=9pj4EZ`T2fSwqL(~DWkuTbs8(3Uk~=+fBW|B*BV@T0Fzknz6hlyWei@D z=HYmSjW>D%8WSufpl_O$D_1t&-OGkcEUC|dVI}MUqS%qoj*qCE_|qNRoiZWhx(DZ< zau1aWNpS&y1QIk1W8b|I3`7;{cZe(%L~Xr^WeZxXr#ULAze*@sCskL8uhTayKB z^0RCl96<8cn({{X%~n|avTu0%Rt*s_1i&uCQ(jTWHRFZt@u|df7owKU=-$%Fa7|ZZ z;R)YFzKe{TK@KH>3;_M#ACnn^hE_*Z4Eg1J?HXVBB0ZBe50WSaC<>mo5s*>E!($IL znrgaXB6p)zpi0I%98ywL*yTpA`3kF$TQR=BRGy+1HSRB4`bL9*X(IT1Cc^T{T;IMb**XdItvspqiM$@l`*3 zH~>i%Qo=zRkO`AcP@iP1M~whbcNy!xjw3axIrfSgCloBu#ZfELNVld zEiFxe6d~C6eJHzHf^3|Z_5T-ScgaH$_Ta!pH+Nhp>- zB_a^dLqKTT`p0_lr(T{TVIH!ZvHWJHrW8OyWU?05il;FI5FcFE{KAFPt%tc&nkeM! zRlR@DjO{1TMbF#Hjj6%6%?n(wr2n6r1-}gw7G3jJX7o2D44$x1nxdM#mxJ}pyy~V4 z#*}n0@q3Z-i+#3pI!S$#@&18%{2`s2YhvrZemYe|E-B?0E!shRPjNWG6mV$Gd;x*b ze_hJiC2LE|8xDtp6eZBSD6D*L>s0QCwQZPXI4qe(Q<0U<@(+i1jP8eY=^hEj>uXVY@5eVxn%}4#mXs0W~#VOn4!qj4p4i zvFq^xIJ1KmUfMM?%9Co?^N2V(Vn&Xf1T{Z=sqnT9ukqQtBTe=vBC>eZc)tzZ6>git zR#)Ue3qIn7~kX?EFnfr_)jG4adlO{&{={7%i^?&yDuk3C)F+*gTX zqQ}_EWDh$}X z`%_r6+uOtO^ccy=ke})s+RXo58^%zPWMO=^e||O}+oyw?`_GTq1OJqNo`8Rz(4tdy z|At4Qof4xiqBs-Tuy-&pe_Mm%qFyi74bNM5K#Q*Qr(@#OIGtzTQ&U|X05G8tJ@NeF z*TyX{0rP>qeNT<~UVs_|U1eKd<-fbcy^r;xJS9r#B$|XY>)p&O9guKVIR|bKz}G*u z|NTe<(v!|s`v!8%t*rj&y^rExVTn7a?_&2-+;?dKuPk6Ny!oFm7FC?H-L^+gr3fjgQI9o(oK`(4Uc8|#C&?*5AVar{`1Z1}Bm@&rCNw&$Rt8fPe z!>C@1f7$?>- zl*m$3o$UxfbmcAleQ3(`TwcGZAQ7?4yM*Cahr!pIL=7?0QR z^_0FjpH*^m)ClbvE;9K9XxH$C>j7=+<0QEvbGwQ#0tiXk5nmr&u@d3Rgq;_*LW8Vq zZ%-fr&-3SRUtr_o^L z)d66AR-Z?SG5h^H;VGbVf(i^jVFb5lP)k(|4`a{zR1UW=B zU@L0MzA~RhXwT+=P|&LbVCG3-%IWtfDA78(wkHYpueVIW@ID-u-R}y_zq6_yJh&ZT z2LbB+08ZaqQfaW&nq0g_ce(s`brbF;3r92p?VfmH!-(uICS4q`!??wzQQ}3A3Zz@J zhC~hlOmC0P!{K;@L>t1?7O(;kaem|Vwzf79f?eOxP%T1j8b^-2eYS+(W$e2Z&NSUU z3`mD2GBZ1CW?``(tl*k26b@@0uam*pKA78qW9tuUIni#NgfNl)k&vmeo+SK5D~u%U zr)(<&TVANp=~g+vep4uvLf#Q zsd6`5ie8w%WRo(yuMs!QCByRoDf_jw=rLlk%JlP#vk6mHfXL5m^D0cg;El`(1C>jY_w)v%qvz`{p_hz9O1 zEV;zdgc$7bS6y8kkZ4HA73=W^ijT~TrdDaq!-uV~grMrraCHe+#+?Jiwc>h`xGC}RC$dKcu!im#TG?1fD{ zSTfyh0TmA-dVH3ntE&(S3hQ+>d^wD$3E%+&xWj~Amhl~^fQs5|us6b5Y^qG9ej!A8 zt5!z7{pCF7oA2Y(hH=Q>gaD1p&&7S=wkz1Vqk{vPOOe~N=Sj01+Om}(rYQXx!90~Rb>W!_= z9q6IZPHq_trr{nkQmlA(olC>-#VXeYB}BHi|B& zS+{UkkF)K9F~LX?J3rpc!Ojjn33ol%nA#G5)^llgH;`<8nRMNg&LaDQw{{IqM}FEN z+ytlC9MQP17dj}QS>{l46qXl$GYf0u_9yvT{g~k5#Z^9;D~$;A-y2(O2{+uMhHrX9 z?4(SWbe+4`lKbM-Dv5tu) z>{*gnT=0%mkozrft@28yRr;MA9Ej+)B^;sJYp8e9AXm0ydC#BoiHeH8bHWC!v60=l zb?Z5w`HMC-!eEm(gmrjpKP`P%>6ke>ZFg|_A+EJ``zXYDh|v2H>Y}5iy@w;lETZdA zL><%@9ApvWVmT->1DFUb7|VY~nj!j8WN&_&#lV*@%9fV==#~$ZFR%F8zx#Sq*QzJ~ z^xe95%7%9bl~}fH(Lfu-PJz)LiZ{glPQZ#FQwyL-A^86sZ|FSqd!XLJn64cj7ZMC| zE+ecIP*7anrN=X)nW9C8wIyi4WCRg48wdCzrZGr~#Wf(YNNf?o-MbSY*1|%$+q;Cg z{|07eqM!M_7~<)E43P!*)`%n3gM;G@>|A%WL=hbB@C$`WI~B#+UlLIe=PW*H_blv% zgnpV%WKt9xadJ0S_ zgYbIzD)~N(dmyhZ)o3GHo|D&r#yQuAa7zT;YlC*JP(GksvzzSntbhmk^*7Qy$#6d> zhd+cu=hH!kzuR}&yJ63$;^&!c%MYVi-U-mp+ZMjlU9PxBLV*li4^US=wYOuQj|Ij} z>&s;o=56|6@QnJuepN#j9OCi=EFc9EzTdrj+%S-1f3o5RAU?~Bt{{Nejc8@pp-o~h zDWlN5d92Cx^?zQeC%RAuoaAZUomZ?_L4l-FH>iGK$q+aPD$8@r`smK}gE?tEG>rA( zK70rG<>#(%hD zX>G=yWXfdFg|)yAO&*o_Dm1gNF8{*Hi5obe2L?niWh3G-HBygU_eJ@C@u&M5@)8qa z&_plmZwvW*k?YC`?yTF+y<{?C=dKXc+YhWz_MczMmG{}*p`t#iHdfddyK0s{})1#+**2WJhD1`meFhPXmS7ef#hC@)SaY6#5B1$K@v)EQES?sEP;p8a@Xbxlok%zU%bpItuXh6;rw zffX`9xG_r-${)$A`OFTo{Psrb4@Eo>ct!@;5{c%kNZJ7b;r>jw(EMv6xERWm^;G=N;RNJJA_Q6gvdS7nYxvZ{$~!u416ck>{ddGYHgHZG zp&ULkDO1F)9qON5fVu+K7YaQ$QpwlHWAd8{rfyMm=`oCCi3-L_zZxY%1AlTFAyA17 z*5eKus@`lHH(r5W3EK!aehET0GZL7OD*J!UlS(n6{k18n34s}DR(dx#xA;6WgbMDW zr4Ukwq3udo7@zVT`TjS&1r%clSuU@c-oSx3x8tA+>cCnS>nB?q>gyT!4FF$3NCjDT zlmfkyXvW*Sd)JnuUMDEH%a9BR0g|};#6w7a%AZ9)VMH++__O!hH+6)X5$d%7+HZfG zRYdpmiFr4s4N>3)aS)Jbg&JOuSglNBJIEFE9^_#+a?fh1QDBk;Zb0v?hxUyU`~YjD{CU9+Hw(j!w7$UUxFLEx z1Z2S6-aaWg>-lY_LBMXs1iO~Z4L^n*8xQ~6cFZ1c2hm;vIMx#29KKW-27XA) z=~fo`q&S2-gqA@A4}c|8Vd!@?fl%P92o}aQDJ?5>ZT<}4N1Q{#J_r#9*~Q0MM`Bo& zm3$2>w#b;tcud+r=0rPR2kdvE`q$<*yhw{d4gLRT>74~YJts13{zV25~ZHziKL#;Wbc9R_BLvHego z1m)!7Ap$URaW&yyS0o#YP%yda7{%Au7kjG)vF`T5OWQzx8g@z`gEuwW6^fgH;GDg6 z8HtIGmb*AWi}2b582sd0AX$k|SA~Tn{t>EKg{4f?ty{05vezdmDM4rRnjMV81?f!j zX?!GEd!4P8oJ!PFk|FQzR(!Xc?rgsSN+NuEk*N& zunH6moZjiv_})7T+RXWUvmQSD@B-_q0#gD@X7!aP0?xDTu&| zpN`IkeFjjy$`5t8511ME!b4;ZQPfk!-rTzLpjwuZg%F`o4^Mk;xS&TJy)P8 zAH=;9TNpg>9&UmLr&ytK5iXci-lg~HI`phkBxmk~ZHjPY71~x#Zf*^v8zhV_VpT}Z z!jVNTPgX6J5k4DeO00#i;YO$6jRIt38GH_VuC{oE?Dl2$vXMD=yeI(Pb_^e^UeB(M zt93bX=sYsFgj@nCz0WuvikwJ`ft@r7$1{T1^a`N)OKcCMslVU{_It|4R>WhNI2!R(9Bds^Bfr^ZB%&TW` z8D-cJ53WTfZDAs6o@gl``h;yD`T(+Ldj5O^x;BUnwrxw|Cmb{irfBY~NAVU(c*Ti$?GSq#o&ktAxt%Z!qYn% ziWZe7Zns`frcR2A-W9t$0op%He2zVcZADX8kc27lgW$Ymv*M<#g#}@WUw@P=6%4nT zN=4$wN`5V~urf{yvMb-i4P}HzL&CxuBkx^%v3t5HHXD2DWa-HT9}7bLqpU*-s%y$e zK8qw_L2-bEc5smh3-XLr7%YP(0$)Mn@ZmR;svHRd?Z{a-k+dWvH{ASYpdl_o+M-4~ z+f?PZ%Mip&%qP4>0*yamPYwto=C|l0nqs4dQbMaV~o|wat^>5W*~S zrNu@oPOms=H*O6O`CaoBsY$q}zytZsTesdCTw_8&bkvAV!*j5bOtfTX38Q#4>xp4{2%13TXiN#$I>=a7LtS;?_Gr!*SmB1b2rmC$|$Mo@GvRmh?A=#w?`$1A*VuqD_F_u$S_UMj=mPd@JZ<1m$YX)3>Fs_8of7javs6? zh|GPnLs+;jF|iYo`a)0nOT$&DBC|NM@MQ zjhBLuCL0&~ZsE1)nV5Qiv{+O#=x#(@*42$J=vq#U*|bexYnRW-KTgoD(3h=%hY3i- z?JvS0EA~u#y{rNrBr`t+sJXzZWFD`)IC^5Vv%&5NHXA!SGX?jGQioiPu@GJnkzjy5 zCs=JzC##W+LAZzqe~D)H3?LCn$Wi&PVAbeUs+N`mWp-tR)F>nn*TlVM5X}LHOy|Bj zBl1#5Vf43``6}UUF)~AS*3cI3@ES5YxsM^11Cn8vks8AN1hC_Na^$*Ekkt;rwLb=t z;P<&4AWG8xeh+72_Ym0-^Kx&|E_OqyA?An7N5BdqG>?zha=k-z7DFlfP`Vq3Dqp=K z_r8E1Tm#S!gv7|kb_nnPts^hX{rDFYEJ7jxTFwBCd>yKyLT9*&gezQWYBFCD57-)+ zyHx_?a}6H?rqAK-Wf&460w%sXx!bZ+UnbZP=383vw%r~-#3hXKBS&}NgxJxW7H6D- z8>JKj`VnpcRoe2@QLrG~3?mf@3V0q?Zk%6%KTec-?MBrnou<8J2VNDZ?fd7K+aLpy zJE^wk<^b|yoj3rNo;-b;062zH@Zx-1I4~kX_++ktm7Yi)L|1)gbqIp=1s~7t0}5r& zLfTQ|P}R|-$p9o~9AwL$%0J(IvdHBEX5RAH=i8f_A`qNJxRMOk5R?zWxp-{$9NquK z+k40L{J($SC4`WyM8o!>y`^PDs6?TXhIU%orG+T8G_(h$LQ5*`LE1}2d+(k0?tML8 z@;%SrIDfy}d0y9fyZXb&NA-TcU$58mc|4EfaU93}fN3PINk~}u19JQj>(;-4+CtnT zR92+tbgN6dygfqC zMHkcxpjdb^q3MsqEX@}4vpjT}RoX3+TG8Rvo=t}*&EQ1*Fv_Pu5ojdL)KI2_E}R6E zVsQhAL5i(}slvxvfC(vQCNuTMk%Qo>194yF==HH?tdo;6?=~@i_l5{5O!ikvBMrkC^V(dxtKA%hi&dzcc^(v`_*a%l7b7Bd z&!y|Ys9u7Ah73HuL)}rq-~JAnpLB-8U2%vai1ZiE3ii|se{A91a3cPF-V&Wz^~i^^ zzqj`_^UQv?LbEFEaw)j{WurS7FJG&wBSaC;=&(OZO8%HgI|BDGNKw-V0FO9)I6&sV zR~Kj&>hV)1S$#NW2HV{2khO>7Hl9gjm}qE9l>W#g#ko6~m^^UqK|igW%|JiLXVfxI z^&|5}I6zbV&@*wST|0mN+Yy&re`4iT;XmSsi2@4BtPp4uJ`AD=oaX*;40uTEa4&|BH|Em^Y1kxZx z^oY&Mf8L96%b)jRq#)#J*g6gPC%`NFq3^KA;&K32fFzy!h7B94;a1a+^X_+pXN6<& z+*BgAD4J^u%?N%Z)3r~;{W?5(nGnkkPwscaybVg-!Gs(l8s>JPq7F@M=g}>- zu!v)_CPt1OJ(CL^j@0`^Y)=y^sw#>@a7z8O9fi%)ZTR$dVG6M;fr`NP3`ev*(wtgl zOGtR=6!nGPFol!`Q7nNnsA3#a3g{z6fCXNJ_rD3vM@@~5iDu?Ok#@xd^k;w(0{G{c zh|RUNyUqOPISF0DvzvfF3CDKbhAjj#0>1Yp{2mc35rz@vjAWqJI--HG290x2>;Zl(bm>ThKPZ-)B+O*8t}OB=1xVT% zo16C{AqmWTN!RQxyh5wR7`zLZ|7T|Pu-V4&0bI)d=y#qZ-#;Rm2RV2mP=wCnX}xfD z)j&dzjOf6EUZ`xpph-rgl93t!N>mf8oyczy^`m-v61a~<+0Mn85D~jT7(t@H4<^mn z!h#6*P(k_>u9A0fFzVB6$UrJN=i7@tFN>qZr5Vi2YBM7XBrJ{tUyXQ0%i4`Ncb*F= zZ%t<)CPC!Eb9s+ycj%Xd+=c&Jw`1?#Li9g=MbuDHzu)Z=RAKb(;HreL+u<+B>T#nd zaw-w(GxmuzoaX?vu){YcdKz$%Ff!b%CypK407sl85^zGA5zZnvedbcQZ@CC|IE+d6 z#XlCJ=qb|L=nq0y=?mOdS$K>%$}Zp>@;_sK-)R`G!ROZf!Td(bFxOnda#50WNJpXY ztdi#t`Y+8<^r@>{AdmYG!QH2`>0dr$vkq4PSFDcfix*#Yc%m|+5FqXKJNak5lUNC% zfyUaE=)p(egRI7*$sHC0-w8F*SZR)E7Q*KwV)0kA;eJp9a44O;5x)LXM0K!#GQ3_m>)7e= z$I){nn{fuUJj6x;)`db9Q4r#*psFz3%2sY#tkSF4S&5%Nmrm~gW1FnA);6j?9d;fh zzJo$S^hnzERfd#d8xaXbXrV;;`Xij|TxcREbPkA=UlEvpkWUOx4~Aeu6xX2|?_0A` zt`v$W%U=khnhRa5*KXe24Vf+i!V+A{PzYY|V80=Y4qRvi&Lm=KAnid$0Bq3LgypXZ zHw|ekf)R*_=~42pXSt+R!Qrb%QT_3XeSLJ-xLRY6^?d&qY|DHEkbd75L>%e?BvfwG#?JUSe;5R{i>< zW&0l~KXk{MjK2w$v_u6kWK*ucr)W{|nj~M9hQtMOH7R%gZkq@;QOaBj-D-@A@>d)0MJ|&VIcq><#wKNCg)3x6w zUh_XDBGzuz+Lip@&Ujofq$Hm7WUQcN-*rRhSLZ@Vx7IOMHHaOZ6OPZNc^y35W3dUb z^!l~b2qOh@IHg4XD^v&CBwQN&jjm~u<qy!>CfUQg{;HqjzT zo6M>Bakn>9*Y}NOE!2H--tk)gltwL|kWFq#^F1LmYCYvPy=B_kfT@)63#?ON2NN@4yDdk#u}SmD;cvsKhJiju(-N=Y$*pJ zXUJnmQLBLoG4XbdYW^~X3@bK~spvkdmGkY9^DOd{Kf0}IR_a&6jZx#}=^#OzBk%`< zOU#&SyRq0vA6o_nf&kg-9+2OT0z|5==hht=*a%Q7>^hd1ECi@)9cRlN-P?2NoJrqu zL;TV^&#Bw*Gms)kEt+S?rkA`=*Bw6Wb!qLDPoPTdXq?J$W#OxF>!~@DE+mSfp7n#7b=x%Gl8nU zY*cx1=5k<#lf4dgU7R!?||Jjwh7Qp#6=kUk;1PgeBb^61knj=`K2T z;YUW#Olwp$xd{|{D%jaAZBuVu+%c7H&^(uCS94#5nObdo&O!w}oujfuSpYk0w8*K8>Vm&k2MoIGc{rmD%x}S<}6_W!! z6o`&|&Ov+1vDg0o#pMcZ$!5dnizouprK zw=SNlvpisGFkZL5&dt(!Hd?FVzJBX6Lw*~Bst9e`Ly8Cy`l~-Ojy-i2|IDdzfQ;Wz zjI(@r*J5sONnJ&Ib(Fbjp{>XTd8 zvor=OdL_P6F$2G99g#=Ty%9?$Lgo8lXjE(u4 zrBU&+y$KLvgLHFa6?0!SG&HZLWL2L?HML5-lp;BtVa4eKcR5kF`>M#&G)2_4pt29L z+DUFlk`{;RWAfi#$fbBNDD%%H^>edKr?;MkM&qz*z0>auyQU!f?3i$I){X4Y^=4nXjM(509%X*Dw{I9UW>Db9O-z=}kPrOG;ROZbI3M4vXYwJz zc&P&u%Tu?=P`yL%$M%f#!CCgTxFQ_u4{^ox+t*1mOCdMkcU+z`WJpX&iNsJLl)%(< zSy8NWv@)7Mh*~JDxo;~oe9Ot&OwXtepyW}js%nW`=SSYLGOnw>pZdEB%IJk3J~{u) z^=E8=^?4wa#LpxfN#)osAaTw&GqmE-Dmq%h=U)CZK`uyzI{Mh|Ii}N+OBQjPs4}mj zG23C;I2cO>Y13-`{)-)fs*BTOP7&$?Xx6+?#TZiitH0-Fo2?33{+_$%1ZW;kvyrpJ zU037TKiC{CD7upD0S^_k%YKhEK0}cRU`SVA@> zdzgKt<>JS~H4%;G2^!^YkmsvPTD0E~zd1^_sQ$g;oCBe4^Th>W@S50WL5r1nZcfg` zpC6`n!j~&cj#IFsG##q)IyO2uusT;NFHtBMEihkFq>TKS&;4Ja5$88hnkrJ-- z?T%m1o>%LlXocsVKiX_ehCbJ+qU!EJC?{Cq_0fk9pI8Exsn)+S_d9`WJoOZ$}PuXY(`T*7!@Nq70+UuJy#>!yYHr ze7H~(OYg0|r(~m!{`x3f^s_{LY&ZwW4Xw;=lVQd^6?z9xo?H;=I`zy=N;#`vDtnwy z;ZEgi=FVUdQ?@djBo`uoyw7a|ov;b|jIYsE%3&FBM|%?%WqEHwR4G;e9$XAK)_~f-Dq=q@4h0@VeWlfA+CG3+mpOyqbny{Oe=rJ zEs1WY7y5=rG|={oq1av-xsSky<|J|K-z2vQdmQJUz}l+v?4OubDF5|))4JOWY8?B1 zD}4H%^|JEo+pW!(%RZU{e(cVP^UVU~0h!N@R+j06-b;TOeNlW!K}%cC_5J%Gg;4ez z-$FeuQELwfuI!tsw%Ti#^aRIN>Zf0G^lYWu&2A{1NT~Neb!o>vNANA7>|TsP{_I5 z6_0@}-5uAR=(w|qtQyK2TP^wvByLY2G10$I+oCrOg9DIzY0R_=v_1Dtp;vk}4rlzw`kK={Kf9kRFemI?mOsaIW=i|d6!rWUFqzr$m6 z{)ZE5OUCQjov#@LN%rZ_OU$U+FP4GNQlP_fxn$?;+)CEhrO~R9!ln3;KGkc9>(?80 zG$eWxwU(nv{*W+h-`{BZ*f`nCFyB33Oh!1u&f8bCa`>e~Gh=Sl-WKFDn&o0%sfQ+V z9v!-w_R9+*4-vmIo>&V}gnIY$ew3IQs;Z7MppKGUIa4$|Iy&kvsJ%0$etm6C92K0x zD}GreS5xB?b}<-y!&W{n6>wqBaBQ&Ba>gnIzSrF#OAUBrJUZ8%iDm8=zhY%G@J~~U z-5%x`S4FAu&tJZ1E&i-}@$zMq5~cK+v^h1qA6oc4NJnY5E=t*Uryedkox~iiRxs(h zWV>6%ZdAfWF7p#9@7}4~W<2ddvgH>x=9WnC#?+>^KTtO4{c6i3YS{8T>aypzk(L>5 z`297F-K_ihKT3EX-v&?F>)1$uK(q7S1Pd+y`V+Q`B{oRw{c}O^qnv{~j+@T93}(W@ z&z5h-k-*b@nk$C7X6MVLS%zduVNOuYFYo5I?0tY5#M-PQ5Ol!@{fzZrruG zE$y|hq0&A{hwBkUwCU#aCAAQUXi>St~W=%bw5{EPN?)L*i+h= zpZIFoex5M|lr1u3$V>!w(pa|)%$@6*Fdi#Egw5eI^~@_yz3AHKq0AXu5sRJ+tf_Kg zmIFi8hm^vxkVFwgM|hcrv~0i76A(?R{F|$QY%}pK|40CzI-}h~OS=Kh;qh_8?;aeC z{1a(UerLY<{-Eq}JFPYgd=h*X_ci$d-;n=wa08VVX>Si@ihfC!xJ*2RgJSQiilP5+ zYbbj*bFR7!mIsb{Gn;$R2?Cd=-FLNhQXgfQ-y_>%06JLmtT*o~w{E#(*;^C&!}-pb z_wVe9krh5fX)X1_hl0LzHZF~d@5TsTq0Q4MguqwHjU@}ieOniE-AS)i>;>}58%4w} zDMt{?m~nxvN>t@oYW~A_dl!i;-0O1`Hl%)Y805gm6c2BFy!nEXjT_qc;x@%3hw=6j z0XrjTRJxH4nM8%_W%s*x@Aq14@<@T-6dOlc=?jC9gtF-ci$qcH zNiUxl*Gm75tuLD;zo=$%>yH**GB#r=6OV9`P152eP&QwCKB!DJ8#%}%>)dOb+b@Zf zbWN+nNW+!IZB`yCvrqj!()ld4D@R^r&8zWRj4lQ=n(if%Hc3glj)-q9`1+QmJJFZ7K zYYSd|HCp$|$LG7Pktm;0qx)CYya)+OAsdU59|=@;exD6jj>Ep7%2gV)t&C{y;e4tRmgDa>Hdm3V5%kE^NjZ6&d<6Ba$J0O z(b7ssII-ED?qY!3Sv1ccB^!D5*zB0#_WQe(Xj{}lyLEVXh{M$II zc)NSN?F03ZHirY_8(h#l@XrRS-BxepFYp)f@hJYsWk#RA#6T;UWadMw1D(e@ z{pOq#qGNZ7Y8ljJWT9d0a9xOS6v@Cwx9mwL9bN1O_L(uHlC)P2fdie0_ zx5o6ty9ym7(@iwX)rECbjh^u7A7U9nja9Gza&I(h2FNfOuo7$0birgF@>-pc#OZRV z1>7Pd+rvhhAY@DP311*I$)3$7^TkY7W`lXu?UXg8ao{z2U?|69Y#u^8xq59+L$dKP zyji(_RkRvcYevFkksW79mB`AYR~@gX2Y+p|S?UTi>8c^0`eh5vu zjF0df|B=nuJzU44g&_JL*{I!u_VPh&0sgm?fCF=-7j}nR_sKZlBuaWE*l6YUXT)uT zL+&p#O1g~tInGp`Rfy8UU?nJECy#(_Ha-rm9)l=dS2fO*`!EH}R++3;k4 zrOHvO?l~OF`IcX|l6^5;-QK=|E-VP+xwf@gTk?bmrl>d9on4$6eO$jp0^=q|pwKo! z$a-=ImaGDIVN$m<@9A5yc`erM?=rQ@>KG(Lmg)4?U}JcAF3XyRwAf*Vp+ZE_38t~MkN7ZC$bBd>+{6@$v>TaOy(C-^xFivq&d_Lkiv zqZc&}bRzlbJRB3yhL4(VU8`|J2}KXR-(PTVW#W5;96cIlFFv$>_(@~Xa&T<4ZpIwF z3sxvXC;As;i@u<=8f6fU*>=WLWxVVD7ovbl#^)`xd|pI$GHi~*-&;dqM)&H~Esh&! z`9zN-7VwJ5 z{q^qdn%vXI{qCb2``vJxlw&8>;W3b_4$lc1Bf9tCKZE41i;Dy+GM=w>vwYn(Z?`i^ z{4ptPe^Qh**5`?`AncI=>Xg-g)dC0`!FNpW>)X_zY++}%QyU@ zUrJW}n!8kp<07lEOuv0%*EN{EbUkWQEr-o#*CPMlD_@k(-r=fIofjM{4`tZYk=hXE z@84k7oXkDU@1n-~`+-_^Y6WTcDycDZJTEYTKW9Ft7 zf=%1{ZAIp~T1`bxEFbSaQHi62P5HIT2{fq9&!4c_$nC|ecN;@iSaVXTg>8?s(CpeJ zfglnq>Y6zl(f-Jt)0g)(;%5BK$2N0n#cG`p^5a|c^0Qwxa#GKok7`Vo-kC&d+7_!k zMWK1s?;zMSXak%x8!sY9Uj5pOt^$^q^))sDZFBusmT-Qs?_HA>l&?c?fY$Mq zIUx-|n9Hc#@fS6^?-Zn=Q4vV2PuEN8fkB)-W&Nej5l$SxTa{gxAJ9wq#;g6vYm?qB zH>D-w8g|;T&8|JaniE~pt`erv&B;yoe|}<1HN1#%lSWrhIXNjwa32Z?Ku=6pPfziC z8po424tF0#d$^{*fF1pzLvN=?Md_>5E%UA>NNRp4`#9 zfRozr2JYBssTE5DqS?ej`_e3G*@WBeVn=I8|q`0H5 zg_WV$oO8b$regb|Br8epTBuMytjZNh$)hSFw74HqiSk@g9v^RhSZ6sVw)2xAw}@Mo zR8ez^ZsljA6{&7UMtkocKlBFclJ0f$?PXQ|T5lSSu|;ZULaWmhnCrw_GxnVO;8j4L zX1lQE(4l)#rq6_1(yciC@n%GCL!wEDfdP_Q7A7{YQ09syr8OR}Y;wG2`Wf1zIA zZ^vGX5d1KoeoH0l{L-wa_(BU_qSLx6+lG@~csBZjBzk{9{vwhVx`t*o4bhDKl^YTb zme{s#qzr#e~-S$KJ0Q%#=EqB#9ov;91-r%W6bl4tNT8J`sc2$ z;nor=cfO1j7D@@q99tg}9K3Jdklo2+-gV5Lg3zn)rq_^S@|^|-Y?2Myy`w5t^IHc7 z%q-0-E{`_-npdmw`)QxF!F=e;JL|Ie4}5Ny6IkK;M_psQprNtbhgb$jJ{&3DN?6$$f2auSEI?2A~ z&=pGe9})cr3#I(eeGs=$tqiDrA(CxJ_j_zphJ_7fM77RsNZeHL$<$Wn6m@>QXOPHI zC~(yc>s)R4+)>W+UWF1*HF>ZOL(Np0OM(!qH}I%KWHWr)PP=#cY)Ck&dS$_`WKJK`wb}c-ZhAhqK6asc)&Gx4_2*-&JcoQ`Awy%{0 zDfaznuWIV_$7S7&YnwMR$d7?9H#fBCH#9)1q(mur`E>e4Q>MV|UjqqFvp+{gKO7Oi z_9K<_NqgUoLd3%IsrFPMXTB^JH4(Klp^b`yWW?2ao}i&Kr{zywhsg}`f<8CZ)W=aa zwVe7Z4E*;@n?o(FR4b7W!z0E6>}DrF&if55#f*xw2?)?BHc$79Xxv^^SnBq;;KQsK zh|V}t#3&w?P{QBce$MrPXb5tW#uG9eFe#llrF^c0eI9A%r5CpFVo?|gSS~oRn{5Pv z^+DCv<8^WE-`ozQ{&OSzpIwD^-*I$Cew>>gG~H@P+O@Yb3{6GP8o$`ly7@QfyyA@Y3;Qf z(w{$lx;|?-Rcqo~0P3X5Z?gR}z~$l_i>aFVINoYgBm^HWt`zauZ=mYyFMWNzGL&jv zhs$Or+0XBy6`BLwlt%d#f6ug(WX;}DAakf4VO{se1d0$2|8&bzP7ADg_ z4fm5KJBz=zyl_?fH8id;(JEx$@X4)Fg^ec#4QL*up^Is0J@-m#ZY?M4Q6td)`BC9D zXV~^4G;35UEh22^U~*k{1<$i1_u(Ox3Z?Uv!PmAj)UfAIIP9w(%WMBfrXj>`i5deu zk2+G$yoLYpVNCr_)j5w)N0}5-QO<=Aivj*Rs*RRli; z#-soHI7Pc%5Q;ES6e|V0=X{MpF_DxaO=H!L=k&)akKFGu9qKsUtKg=C1t7OpAZF+|^W6-+1s0zW;6a92`v3K%j z<6?-d+}mCmX>G~`K`B2zjHLHc;6c?m&wY9RTPkepmBQ1sZ`AfLQ04Ug=v22&9bqPZ zvA1J~R^=jTPUF(W)`Eg#>@KvG8n~)pA#+~{{}dXF3`rXL(2!&Qbg|QT(q3-m*Sr4y z`Z;7f-_Jj^R<;?vg-CGo*@Bn7X**5!kRdM#13_sycOKJzD5yQoM=4lSA3JdZwJ$0^ z!qcfyiAkZ_I;S{LoxO{ZF#(Wp@p`t=c`SM9-RkjouR+Y1Xdb5|lf3c?%06;XmynP} zb7Q2~3pG?1`$AO@d`&X$H$)$0A)W@>cRf-qSutWnEH6VU;LB+5EzgbH+K!@!rJ-R7 z#p+eD?QQ0IGHIV|O0BY$Ltnl6anoF$%R+jnb00WMArIS9Bu9b&^i0xrB$gaV>;QFy zn@x@8S(eoYmiASRUk$1=(v&AXrVwvf8n$=J79}H-lcTlG{8EIFrL&X&q|A4)kJ;sS z#~kZciIu-s%PpIzW*r_r7Ik%N^c?-W{t5dp_Zxk->?z%eO|-l)X}n}1mXXOqN;Bn0 zAje(8+iy-oy?YG2;9j=|2u-(OxxXw|{BrB&AVc6*jJbHx&BvMt8i z+%|@e2>P})z;}=jTFc##&Vz-c*_gT-dsoB*3Hb*DKR8z#EQ?11@q*Z)kBsIlQ6Gl+ zo>}M6BlY1<@3u3R_r33}D12^E=QtW^lLO#Fd9aB4t5??-XPMl!6A!1Q?>R`I`os8n z^SAN0v`hwRnF{aTZ^4lIWPy8hZa_Ns%_Vd8huI;YsV3>Dw0nh5B_);x@=9dbr6wj? zhkt2l+45lc_Ih-6M!i$hY2e**=SRJBpKZ$1&k4TaX!VFvm&jG9nE8ER{XBaip40}a z-0q=Y9JLF%ddp0Hb*9&ov|ev*cJ?_s_-gJF_jpVR`ui9k6?m{nJ7i@ADcZxsu0R2T z%&*=7e@D&s_%r;r%#`1${bE9FN}Y1&vI4BdgCK(Y}5JQ#7WcpncRAf)86AZirhmq`lTPc&a1w$W-@Fm zOp>R;;h%2F?i5k9$|E@5<>j2z{{%f_M~?-Z5GR$+i=N8vKbSO24)!&g0m4sCq-s}< z_f7OyT)2Fh=%&Glj6WA(JAYcxe)$g6?Rn5Zh{@;GM!y_Cq-YasbzyqTm1s! z8`zewh<x$uW;6$0<+!fco`OX5yOh~*t8KqQ3zOnH#q5WgA8%WCJIv6&n`>5DSn$g}TdE(A zD3{x=uwJ7o)a}x?VVUS_=6_0cX3&foEIs9$1EuQO{aehkIkt33z0DX7T^_>yf-b3# z+q#r~3$2BAVRDsB!7Jad6gJ$NO>(h!vl$_qVMIq)fJbYdWt&#ZQ#$?T9IAxUJ-XFd ziGz3HSWXX)mOZi*hrDtA5vgly^XHTl&7mGn!fvDnS{{;%4>lXGtL{>=%MDC@3Ukr) zWnA~n?BKvXvnhir@rV;O2y(aVE*Agb6^ea=IA##%WbQ8PqageLdlD z^I_FFtx<~IEdF7Pt%B9*5-KnEvP#0$xbfz!NbN!(Z_M@hySjmV!{;NMj3!G4?rCu% z@$BNxaA$HTCi1;<99NPSJC8w*7i`n1+bmW7(oO`P1Jx~9*n|Ub(sLOz^CGYA!BpAZ z5OZX^#>b1EJZrCxD>_SL_^#(}ha%3!Y}#FjvD8DCApQ|YD4b&QH@D+H?zJl-f<|pV zG?M6y9_$(4^%WWXNa3AGN$fOcK?8QCf%8dStYNb{74b>nkR< zniBu?sh9seDQFM;nVn3eM{+8x&#HAa>f?p+F(v_^!1Z{IIs3)cpFg?SmSrh%iLdqdn#iR1Bb&oLm z(GRn8uPLQsJt{Gh0Y2LlYCfA!opKpAHZgez(;c8J_vWnqc82+qE~3apS?tdLQCYpG z12Vutb=%M35|nrT4bKlEE3$8KRcGj@K}l>QRp|Q>{JC$b@n`NyE>rcwYxll=4<>rcl#0{vRwb68I#OPTm|i4y>|z|AxBQn zpUSk@$nhpOEG3^j5AcVShw4e{tbt2EM&d5rep#H6bxQ7?WkP&_ay==88jOPmZiD6o zn-jivnSB9uL`Rd?UK_nXJqU+=U$|zt1SyikmOpzjy&J`85LE&y3@%NJ} z$Q6w3_gxFoH6JROO=oMj0lAmJZQmt{esW_oGuyryqCrdO9UXDU53@f~acHd?VW&0j zDc+1=_Bdi##KQYHhfMeLkBUW;rqQIAA2n>$?ylNEss1~@eSdB$rSY+&KVx%hqpLdS zW)Ip1nrY-^9ziU!Jr6^Xbn$%Ac=Xn;NSQ_X^OHAk$_N>|ZAP*7N3?J|i{iGtUorP^ zBPqzjjx!9l&Iuo!@#;pAcWq47b$oy*MGs2>lb)x8Eol?A3dvRi5uyuEW*KatkFcYS z*k{n{9j*5gzJqYz9s)}l_ebKuT6)pKW z#KylzSKSAv5c?CKkM+(17eZ=AA*-|fYy|LSCj#EB_&jLa`+R!V6~${Zv%h3eL%JC7 z6P1C7y%_&KQ!+T^>ct%*=nH&|Sm!zdoc|oJ?PRc{Ca9=4!n$AaGAr`Mbxb85LFon0 zFLNSfcD9!sPqk}IS7((9`l(&6Ei2iNf_ByR)qF%n7_pJDYmYf?n3H*9qQSPQeksif zuh;7-ojW=wwjksnQ$?J^qU^tz{Q}R)%JK(lp$sbHLxu-_B~e{yCw=$HTi=jjKx?;T zrrz3g459tAixRgr&M*!Z_ypi^<%D^+GR0Xm25uyExxz$%(O_H_<6=eE8 zGt6)GyMvs}*@Hg1bXR%K)-4(3`$^k~kd3L1J>s4tKaeD<6(67VlysNFJ88g`SWli- zysNEs)pxpQB>j!{?J%sd%Xj{2KIBSi4>0k8V{vxS3B-nDS9eF8fA$#^TQ95*h~(}! zj!<^@^oVtS8zVe=*+wSIvBH?iVN5pI_Q;nta0k>bG}a%~3^2{jX-!O(wia~vle@T| z#|q7MN1;w3FVWT0V$Zf{rrXRh!nq*?c00Y_oCF1bPy9SLPb5rqX_lwwdt@`M7pQAIMeEu zeF%W@UENIbyZcl0_GVM{}eeyo!^XF zj)DgZhtfS?+LpMa^UAi z^|SL921dpU(HL{&cj;^@t4G?6zx-+4JR%R8giV)era{@NY6c8>Y17*|_Nn zdivJr24NZQe8i=BwQD5U1v)In zNp4yX`jy(7UlOH-w=;=Ux-&Ttlm|3~1E~{ch&IBD*FS0)ld-AfVDh5>;NAb3DT%V& zCh`%#hH0~E&9h3-w%1WOV1{14nNE96xV`;SNN(eCHs9|UkSTute3yFIE;60^C;{?e zK45$Va1#0Fb|?mim|{Be9^$gUqs%wWR^X{jxNS!&_A$kgZlF4c zkksIod$EUM%B=gottXS%mF`YHn7zAWqhqH-*%x)hndHD5T)kD*P!(l@h=~jXc1!!a zqoS?1cXSn~3c2hd@93*gblo>2kZL6Uj*g&x7uT*e+4pSFK!@-2hcFsCx{GlClJ#5N z+=47nl8P0i-Q<&~-!^$f$##k8);YO!|D>z}qJ1L3MY`|@%zaL4d+$J^XsvXTj-Nh*0N@=8=yVGgbXGh{0pEITV_$?{X)?D8x&s#w?k?HJ z=_&Qzk25@mO)rp1G(iwDoZDXdWmGii7b29?)7~f})8IXvfz_;JUlnGl_*V`90a*JvgX4$`L97 zdy?-kdP(Gf;J2o?%cH&to5;VlRsE|L;GpGLaI$`N&xg`5LE7(fQ@$M9v$R#Gxjbp} z|Er{k=}DpG)9Fg+<&-&M@|3FJToHa@ZXXq*DMd-9$){y!Si1!3zS~7Df}gjx~yeN z)HFknol+Ehdh_2s08cPW#gq;IfBS&{`&WOv{;8+Ia zM5_pNyL*v3aJer=JpI$eyBsspn&}51m}t@>zWEqv3s5^KRe?r8&wklRAWGYk5Z7zh zMWqNgg(WWrc>)a!EGvNY)1!W4K%lFgg}x z<;#&@@S%I(tbJ&q6wECFh{0%-BlZ+*EXF-ne~>*v2AsGg5GfP0vr&NJ5~LK=nyT~c zkE7SUkCKbG;KyhcF^*SxKSV$QY7INk^j1S@pS7#DpGB}i@V)_p(CWv}Nr8HUVjlY; zzSvGofsX)BLHcH4S(yt)7?UC`(CL2-Fk=K5Ty6%S-M~rXIA)JDGYA9(q0Zq0D-vS@ z|4O~Z5*h9ygv6`W`-t)La2>R-{v^v<=nDes6YtMRwB!>2J%GeltJ7Ejq6`_5zq68f z6Yl`zVl=wlkyH~hzY9PxL2E;5!V~ZVY`ls}%8eT*`+^|Xk!t6bbvJC>*fl!3BBlvc zoNf*L*!%Sb1q4e1wL9v3zVNiQK#|Z23oGisiO^AWZI2XlBh#@hkVp3$XbS*m5aX(V zz}fZ)BeZ3~Q#gO&0{JE?DvSqrL5ssWfC|nM#JuOv5B~GdbF?<#EeS3sF33pI0BsU( z(xNK_;O_?-EWnaFivD7W@W(PV2TTDL+0{8)&%+mqa~qV>^?9ls9GJ-pXx$|Mr7?Z>*58JHXHZi<)5hqExg`l(ay7;#x3Ah#rPD0KdbGl@87c&o7w{ zAXkWy#CK8+rHFNiNwK(J5Fa&8$D_e!V}~1mTL<`>yn+yf7>DZO^cI7UN$dp+?h5Xm zF2>6fn7)v*0c!xH=>a!V1Kc>-s67-N(gZ++XWSWRM-Wf0@VB{+4d+jxY%B^)BkAcZ z;hcAZr%n;D%^FOxBPKTB){w#MseXS>LogaZb4~=IT{Zxml1}iRiFs+sA5h4i*lAfm>04K@Bp}heZ|KIe5(p%ukpi0FZk1Y{XRLq$KV?8M7i{N&_Z;NCEao%oez4mjfI&Ds`l% zf-#f;a7@CMLC_-mgjXiUp90hZijX$eJH3$AjUy*tqaUX(7QzpJV58z!?`hos~QvmBGPalBVm?e6;s_o5lhsmK1^1NUcd*cSgf|I z3;lG4H@(~J>;^y>juIQK6){4N3kVxRSe6{7MVV8o~@OkNiT0P8!( zg5dHo1a-ws9nXXgh^aTYJY>N^USq(zaKZq0(0hp=1i`Gkv-4h^)+Ox4;t;{q#>Cc4 zOWBA^+W`6a3VtbQnjRYHJxK)*Ra-EUy>6u zQ-~oB;6-Az*Z=@w*vc`wAnT3duO_n`_zfRQ zh0H+KuPrad?e#|IBR&u7SbcZRL+X1#-@u9S zh7(sAFeZ+j{Q)G54C6>k6{d$~=~H-oaM61(n9g>(TD+$`V3(Yn9Jr1I{T(=UfNN<{ zjfCvnIgABGy|28}47g-oNI^lXktzxf36ULLMffs#`d6Ty-@yOw71u>D19} z*p_t#2DDbFe|)?O`OS1G7Sw+_WDC^%tR5TptGU{S~g9|PjE6<6Q zWrgV|1c4NZP~M8w{lKacn;uYNGCH;;a}yJ!-U!kqtd@`NR@g?}9LjNQVgfgaz8o){ z@xao32XyJ)jaaS!o*>eS( zgviDnD`0$$+Evu-px9W~@Vw0X>xTeJy#H{nqg%7xe#wBK|DmjAVY*gY;fsF2$puYa zhl9sn*Z{DZbgYO@w=GM67%PNPu%Hza@X#-N>e#1)!KF3)|Gus@e$nA)x10 z@_gN*VWo0N^NIzAB}%T?H}zLw=Yj@hLRz&0UH0CYF&sV6urV^-K5&lb2=I$qS4IGD zbn$wR^=eY<^{0txK^$`mFuSh+IcLdnF9M_lun!vJ%6)#OnGf#;r*IweJ7rPF-VYMA zZ+H#FFbRk{aLUvz?7_W`vgH2)PXp!v!MH16QkbBCquvx#c)_~Hgc5exc`b=sOvk+$ zE3J}n#@INh0$wYd?L2k}y9;o$ZvY0V-?;>T0hNCtrKrusJ%sG^5(!ZPMuh-=0RyMe zI7*PbwGNcSfbPJr*2;9lPY7haWdJlaL4pc_k>NLZl4Le01CItFa1jQ;JANg5H?j)Q z_<4Q(SY2ElL1RV_j>*pb%tcG}$+qv2k#`0;5R& zCiS~4iX^Pwy(-kwt3tvzLBYc2mzrqJwy96nV1my**eZ89JJa-1Rdap@lU*SrvRu0{ z&`<-PAL|tLVPA3boy0$4>HP&&)n*EEo1&|Vn7iWpCdX`WC-6~w-Oyx~mGw7>bC4u} zkQOxYC~AU($e%4rqYAt#F~tea8u+#!CAA~A0nPdSyBI;jgn=*Ds>7;5ey;=(1v%;< zw}a|POeE#eZ`c81CY)nXfQTtogu??WTi4Lg{f|d52FC|vEf5mdU56V=;Mj1AkVB2x z2^5z!e~xp|OJWizu=pE)<6+b$X-g9mvg%bFDsV>sksFeA!5Q#DsKI43tB-05URh!6 z7Q*KQySz5r#u6CnnpiwPW8^&Wy{O;6D)LU~piiz-rQI%SzX!@Ioel z3sWUrh93%XYQH#P7s~k13O!+Mk^ubu;Yllgi5*<-u0l!P9vQxJYcuCD*HHe;*4JwH z6Luf$?n_uAfZx7@QGuz(p6_lwx3@WAtxs%GaLBvwbT=pmzQ#>4|~z9T$0B_*p49ub@56;gEb8&KvriV z{9kx;+;RLzsy>UNcK{(D9D4eemKI`DfUFHp)n_j`E_0e4n_QwL)?h@;45=oI+F@cEX?I9F=9nmn5V5y@3zHk;0(KF7X&0w(Vo zP5N;P{lE|ey{8a~s|5b$sa6kzlAAO~C&G*cXV+(br%Pcr8fyk)zK&Ly`X1la+sJ(V z&7;PC949vb#z;~pf&ttw#3hCL+zjy0|5at`$s=sr-wV8590O4p2r@&7XlFgj;`93F$(8XTu6&)=BoCCN;4dp0zam+*jCKq5P#~z*YZDq^dB|Oit7Z)(38iFUcd|Ilsw>Ji93O2Kd7m7c$p+wAY!-p z3P)H>!7==5^uK=9iwz}Ac#D4&J|Bfx_6}s|Is*R{E6M$LAj#1SKr!Dqj37kve_RmH zYZe7B1UNDoX1Z$^MDzD{iXGikadkJ1=kx%>pX3ze_?KQU{%7`uxMmDw`LETW|1V+- zaVP%6fRq2zH|jaI7bBNInNG>Ky7$c4Sy6Dkr^8=b8(y6~5$2DeKPRaZBt0x{$~W++ z5bVqud33|z0)C4sNM16`4k&_`6Z+nrKoK=k5k7waf1b2Z<QB_A^a zwJd~i2!SKI>fI^43sG|f{N%kVMkp4++qOh1aQ*PAUC&)cE)xUgCm%Q08k73+%G3i z)nl+Rj8AArE5wv3ke*T6we-{cd6v$<77UH`MyxT|gpIJx-S8I3unIT;1V(TziC(sb zT!-Aj#s4H4XuU^AfO6Kr;Zm5PCcwdQc{2`*~ZOr0W9 zg8pz`33BP;%&-F3F#x(oX?_L$D6g!nEH(rO`VE}Ua0n#{5$+sLM14EoD?#3c&@5grIGAAgX92G#&zDJbSV22DQDWCBuBjJq%4QMv&p__5L3Ll6Q7 zz6~Nh2S&}qy(lO2AjmP>&LZ+bJoX*J2dwQRf!I|X@0Q4Lz&w^S7$}#T%1=yL%RXX^ zMM5B0aj+0{NHn`V_EB&L-4xw^yXXqpCym0_bT^_Z9{oa9SZ7dv-avUE%1$v@8@3Vm zQTyA|&4h3QcMkX;AQ2DZ4#9#wW6zm?g2O_-r4Ek|$Z#Pza|D$g9u*)M=g34z%cdeL z)3R8dnC~JCLT+z_he$XyJhS0CHyq=Hx`cxmILrtPz0op{PHC~meZur?FT|5HjEt2~ ztseV)*Fu9ZF=si5&!7u28Q#0#<`_a@1oIkHH6p~pEKk?QKN=4PwUNv048c>y^7wzsJM*xd^SAF`ma)xXjIv}K zlu2cYY>^n0t3=WwB!faJTSTOcG1e>>g&KsEHrWy-WywyoQXxyI5GhMqp4S<3-@o7e z{GR)M{&=?Icsgc|Lv?js-|y%9`JBu9{XWlgH6h4}rSGQyzIt`v4%z=2u@E4M0FlW=%TSB$Fe@o(Go^Y_j-cMWG^%VF9=vobgT8nm5=TpEV|`s=R( zQzAK+hMMFE^9d0dx+7E7q~qeXYmFI(%HX`&3xaUvXFon%PLjJ#*RH1=c6viM8AdxL z8RgCz?@zNbyi$htIbMm*g{WldPUz(*<~G1r4~LFl!nQ$Uryg zu4yy<7B+;?gUFe=UcLPt;@ms1^9jRsq{VP%TCr&rt--NF~G zO+Z1eRuaaDBlrdtZBiLO5Nod_(~vQ#1UT%iE;jcm>3#QjZKpo;5SHmcDlPLiG*5|W zBY_nW>&?xtA0~cTzr=GYZJD!U9DiZ*Ax&nPP%$lV)vmVS%iKqg_^eyE{CKL&c*-zH zl_?0#hki;fTL#i1jm`<<>P$TQ7s&J;@%x5TzhB%{$|N(kUb8->&L9TMY8({NGl0X3zYbXO2~UCPP| zz+2WkN{{Xn4u8m?2e7p>B#@wESmYKo>t%`$vvRt1>(+pfjQ-_Y&QDWV{j`)T>Pkk* z(xC_-awhb-U`-0S{FZZt({pmBrCwg>qN#iPIMA!?aEenqgW1U#&@sweWNSftnCaN} zmNP)7K7;q1>DrIz8rM0)?5BrGKKn@cSpy5Fc@N@8aZ3v10(}5>oXfe6(6$q>NR62K z0wx0$3{PUtcvw2-&H$YZ{erb~KehcMu;;t7vXiGvy7V&qI}94Rw*@Yj2YZ22gP_}q zN#W!NX-owXL>RM;>I`tLuUn1*Ac+}B&~D68OyY;Y@Q&O*^INX+p@k0PpTKuQF{uPg+%XTKS3DuM?RDRdejazBSAtNk{lI)w|p#@}v(DoX|Y9 zL!9CNVc!56=ntCx=eJh6SIvur9Kcrrtoj3aGJwSG_13-XC}(1BhRd~)zBI~BkDfdr zGPc+BrvDbUoxL=)`qK=+NqDw^`^y_S)(7b0oL`R6XYkKo;3t#%{ppi~-;L_<`^4Q# z{;o}1)=XNn>%49SrlRw@da?|T$mv}9lrfx_=qM~5harkjEg3ldyTGpvdBx<8gFt@| zPUsIjI%%-lvAX}Z^F}@k*ZZe@qvq#-_}%)pekPkt4m#_e`=hLxv}NUM*>o5hXGke@ zgd?M_UcTI5v{H|9yrZ;1BYa>9PA;5T>Y4t-x7YJ0$98=cuo8!~Y)5-+c{)qlbeaAg zV=XKPLhG!H#6ly(aToZaoG%{k)lnloK#xob|*Y9p83UsO(q)`vQE3qI7PTchKD z{NAT`lJV(Xe@)c*zTM7`#qse+ra8ZPzo+kQ&u071lq^yxd{Y{=93I?AQTvrVz5a%; z|5E6g{PPdr*)9L_w-%uGCI9gS|NDOEJnMDc+IJsz-*DlxbxcF(iPvKT0J`3|a>bOV zZi~Z@cIfDv+rF<_9eM5PdN$FMY#dj-TZ6TWBz|H6Id81~3)(Z0KEal5lE2`OcZsr)LwamA-p-7kJLe z)isiLETS8A9}T}IO`Fc4Ma4C%7`$-?>bEg1(x91y|qGh3zz zLQPo>8|F)oY(1rxd-}BAF9C!yi5Hw^%?cxtVW@(=Q>VJ0>ivB~tGQtid;5f}ogbCuy8rY+mm* zfBsnnHKz(8An)F-n+Xlx?|?p)(V;Hz*19oDC1n4Bp`Y^WMNc_n1xb?4v<34A&P$h` zrY*xsJfAllg52O@5IP^Hq&nJdS9Ou~RCoq&+VlgY&UKzjy#_y6f{B#BI+1Fo;=aN_ z;I3c1I076e9XL9cxj{-*P*4zY(E&g`CXS5bDfIO#eEqryHd|>$Y`&Nrw1e@=JcH+b zQ->TReY$%8zCA2z1}TxhzrT~$3QNnacn%wYyk$$5YSUF9!_CCh)D;wPp@+u~gsC{J z84)dg%a1;5D_7_{*pjURnA&rX(Q;cDr8MTx^rSbxG7WZ42DrbzcWi`e$G&~N1}FT! zZW`3Zq%#W-5jJN853iTVq&MgNPs+hOL%35XXJ;KHzo8Jw_fNL3@M_z(t=ZVIw&X1Z&z@;=CP-|?g01ba z{&7-HPR{krOdF`(?y;9urwU)bJWR~WJkx;ldliRAuzN*Vfk`4_{jP_U+d5(|Y?+?(iG)Atu2UOZt_;K${8ovgwWA z!y(?9hKFY3#$|IT%J0qC5>7ntWACWUWim&MM0W9wZo=b-khS)CFhJq{Z^!i_se%Pg zG*ec9`4^G=JFxd}zst$vkVTNWX$)QxCCkF%zuY}*?_InXf7B!K)02&%3&5WP287$L zJAa?trt0yVWYsKLQ^m9v&o%38{q}5~^uQH!v=j>WF1PpBnpy3Zq$`1g7KL(})PDMD z`s;<3mx=S7U;m`Y>+L{we`)a*?+Yyt82t&AZwt>dR`s>j{WN9}|?(wsMK}L>Nez&JO$hvC3 z^e+D}O8$}DG~E6~D7iivxE6|boM-4&mCT-T4QP~X#^{r1hq~3@eY2aDJqRsfRsF#| z^l*W<_cc;@Hm>{iogQT|x+HpP;v~}bqf5Fge0>^!wGR265>}q-qR7Af&9i8?ylGqC zH=*9w-v*Ca^T!_(6Y49HEk^#c=lOb}|G^#oAO7LrE~wH72sew2KNxF!W41vAnW9Gj zxw|^9{Pdga&ISs_n`yPrAlZ#TeSyZn`N8ZYj#kWzz01c^Zm~5XAtBbh9+pzOcDeGK zQ8Lt(AoNUpd=U(TKfkAcd_N{Eb};g?hC&CxQRT$V>!k#Xy#wlk3^J0Kt{6pwotIZU zcvlojV-fRH=#svTvGL+jFkQwSPPspbAT2l)8hZW44Rgi`V*Ud(Wn#Mgg9P;;mUOgA z=!<^tc@rtK3S^q!%1@6Q+C)tpkDC!Qt)+w%$tFfyTwS>go^doujtvGU`e^Gq3SX^( zYsK)-Z+P|EwYww({(*rJY~|~-4Rj0)tRa*#Fjr;Qbz^2@hOgg5qP_i>Sm#?B(e@`y za4dGv6V}wnDXqAZ2)mdgT(10z$Uhw*P*VvLlnqp9u;}?1w+Hbyuts7NerT{dd^75Z zDPU0dT2g`s#O*k6aQR)H2;yyzP>A#5{|*{t{;y?Tvf zG;xqiR@9vFep`l=uIsq$Sqty-OglLmOdH!zEE7q)jY(*99<6vzSoi31ttHNHMp2_h zQw@XBc#r_iesj`B!by6O)caGAxcYoB`)9NYc?MgyfA;|c>=;@|)S$Pp<0a_dBJ$Rp z(+duEq${}63UpPiLx*UH>ta4mt{+;oJh@);N+)l^zBEKIGYvFsz!KjJKwISTNBV?GBj%8pQJiocdm1bhg?Cb*E9yF5Jm`Bv_D7O~SYnt7PGwq6zV zi=p8pm0FuNvkS}=c`h%TE6hf0IX#%>hT))U*rt6Xi%|~E+4RVEQQg zpZHDGrrHBO3b3TRj?Q(pj!b#$GWSO#A@)Oy(|wl}%s9PZ#(ny~RFC9` zwO%^dgT0jr{2+4!YwyW-^4FWtTUa$$JZ4^Et9pe6qA`Tj*jAFu#Bjx24dZ#Gu#-)z%f`RQ89-c zv!TgZeAs09k6dfA@hGB`WH;KBzJzCDc4Ul!({(ka)xT#)1utIcYHE&@=Z-OsA-0^u z*)1(CO(O%cMqQRZ5!K=e&Z8cAj-(s-<_gp@Hs@9>lMKTpEo8kA7&LEm!Etd^(=IkQ z)>BrH8I%!J&mp0#D8123So8_O6Z86iU(cKr0d<01Qf2AJ%bPny)>MB?;_oUxdTMgf zzCM3!JkC0A%snw{3rJEyad9Nvl3yGBU$N~0n(XF(&X^8@Fe_C6+`!#aot&J)@kOMt zz5i8mHU$Bj;escBT;9^D7kQM#2t?d>QDTkRl1SL|?8S>;l-#}e_&$C6n&&yMSaBAo z7m3Nd&O_rdx;%)FB@HZ%c}1574CF>Jka>KJO2^MS)jdm~N`tv3qxT zRFs|!Y(E~`sVZcHNy&-K({gP5vkUM&@p$}60-Hc6CG2Bewn-Ni_^@R+L&rKmjC%_ zci5b`o*7NlQ}+xGBY?KIp0ObJRZeUqkZ|nW`+X+7#TF^@KctK|!fG}q=J4xeJQbZi zDb-HR^4Ga`4B_hSFr@%lyA_Ef>#5$ht*pl&L&NI?EDctlH^@R~B6EQq&aJTL<(AMX z1%-v-j8r>}ARzSn$V&E31%%+3)?VE$l(}=+Ze*|JXkBz!1C$sAx4DXBH?cRqx$AH% z_`7gyw=(VJ-GiB-7VU`a#-ORrOei@QNqBXQ$GCgInerETzId|V;YIDS z?|jAS^Zb34|DKM?-?fr#q<0X>7+=HYV2$&8dR9eUy72vCCOuC)A%{+p+(Q=djTJ*y zHf-3?XU$rZgU3d1eF+Ndmqw3Th2-t@4f3Yh1PPdmW4v;pk3{5(U~93w{oHb_31zYv z=NskFM1G#%%2Y1>jAUZ+l_HLK*Kc3H3pS`-o^Od5zfJD3uGSy%&;Q##r;*wM(}aZu z8xRvnD&o3x;RuX*8B>L;B6Dx1rrIGAIEh%vXK_N!DP+~UVB9%Qa*K-jxm_$Txy7(y z4Qcag-0>G9BL^ltpOU?ba&6ax4^RaX{FHwDXa~zU_OF4Rl|XtG5RjS3RE)~*jL?9$ zg$~@X$@}G<&dZiBcZK??Iej}Qg*{86dnfVZL)X_yLp)_{$3Jvo1Jz34{EFc^U=eYkszeM1wk zRwbT2D}W1-=wY9l>J1w=_Dy(j_wM+T#E*LmUvM~kOg%es&YU?YLj%EZev6MLaTKR@ zt78&U2k{c1S6Xi(Av{ooE@S4bB?R~4@*e2pS8Rs zF$_5r1d?r_;o=BXjy6Tb@Qa;LI!@WQvLamkBpL?tqVdf1-MowcFxYBg~#M!1@v^7 zGMnQocr-zj^|K_zKY5m~(FXdX+@@FP^bcR4uU)xZ=g!Z; zO$8LT2sBVGTed7^vnLReUx&fAaB$gNyM%7cUg(lK2VWrJ91gSJZx`wl;H7&DMuDfE z4R0tr1!(^Wvg|nk3`AgOkO*oj!HXx5%Thgc00!qJPw*}wx%rACOeFRLNj-^bnK*q8 zns-%5et!P+j|H3tbML0i-aNn z(>|j&$`p4>TqUtxN`v5l%H_IhEn6Ox7>=|z2lWz+ruM8^vo=oMCszZ*b_WE)gOU|= zn&xqs!RY}pw9bJD@s;P&NbNUuJQP4oIw(&MB^1IoO~A@xcmxe(ePGz)qro4G zsXGY0GW6Z0mJw2x@$|^#xUocI5=u&VwHU_urmN%end{*aT>9s_5epVQNQk3TX9NW? z=_M~x_r(wZfL=sjdI#Ro6FG;Gyc>;lv7NU9I&g3zIkJ*^>sTKS-n#WiAfiBLFSE4O z&4(T)R0sSsA*8BEs`+BfT8yze|HDo0Y_!fqGa~@gGYJXB*q7~V*RCyGu{Gt)*BEb> z24*$!-qF`yKIIyJ{`sd1>k&vvjbJCNmoja}7Nbz^PZ#6M3}(P8{qJpicyC_A@^w=R zKY|!>`{(~iYe zWvXVGBPE)GsUCIYr%K9*bo=(5ARGzf=mnZ~_C(NTuQlCyG`pnQuWkC*|`;#Eih6vPy z`XA2XRYqqwZ0_>zNeUYwBIo3su1c+}4|b{VQUSoNU#S+ES0}0i|M%=4+;e00F9Qa| zUHY~HnLlbj2}K8c_WtoyW7oeCmd;rqEdPYR%v({{jV5 zAMkr>@D_#cdtX{w#_Zp4nC$_T?Wy%XjHMKtv2ekH@ngnpx11b-(8$Z##Tf@2Zt}MgXT(MBx4afhf># zoIgJtCTLQ;N4RkE-ZZYSc(Sn%hD>17+fYa){)yHqD$T!HR#^TJ zQoaZ-tmxjcg9M@!%XSe|RRB@an@oZXB>oZibjzyknK&&}o6+ZI+r{it58>KM5#S6o z%|C;1@=h~m9OO83CkO@$&7vyDn&h~==f~C50Qvk z?R2WKhtw-0&?p8pv!*gjfYw+#274^0^{)Yrhs6Arhx%h8zlkS}tMz{Vc^FE=0g2tX zy@bd5)fD=;t&e%k_Rpm5kx}8BSs%jsP$VT4vbpi2s1K@%bIrM>fb?!(TT3srD=>-p2i? z{csc@T|W?bB2@bXHTi_g_v;S$cP&6(Xd|_fpR!ZU^v)iQ^YioTXD(R{Z|Amd*t=#s z|1&D8_I2)kzk+;xBl*wLwHV3&ii(my%s0^YD~6hzxTWc%%i2mZuKnQzbbbUE?rZJCAU3tDgI@PVdKlz z)-7uoytHgx-Lgi(+7%<}RMfLP8+5(H zN4ulZ0fkXr?G4qIzN})2^M^)bb!5x)^`9txYJdN~N!>HsiN2uX5z^Aqs$<<4<~|IH z3qPz1!5+UvYmkA9{TP#}2=+icvK^eB{AvEhEd@qR^Wufy6TX8jgTgT9k;V*Eprs!^ z*wXx@tzE<9Kp`&?&Ik!Y>XrXUgUTr@J|G9ZA}`1vyLIp0oeZ516 z4s|CyJaguZZKM&Qt!N_H&euKiYT;^p(+!U)ibG$*N(vEn7M(~PnvT0YO!P_UdLuV? zvZxc_D>vpD^EMF6N6B6V!6lRNsZjGBoCX&s;*kiH6dFU89%airy;hm|6W9n1q^&)= zWw$Zf@81>n^F4#yOt*7qJX2FEYQs2^j+00fBzEhSRB1(DW}Wn7oaC}cHPv?X5TFyp zai|;7Z{S%S5ga;y^afEsN$c12RJiBTva*bplL}%_Y1BL zkt@LhWaEyzvonl7<{e~}B(*p$3QVR;#Y%)!NXK#A8xI~hNInRojB9_tWnc5^L3LC5 zSbZ`b4jNqOiECDArd+zTYo*=N|_M`>AWR3ad{kzP4pK#<4UvYs}0TQK@nV8xkB)s8V2JYAK2|`YU<8tx5DpjIR0<9 z#7)qKj3go5J~F1xhV6u85Nf2#lGyt!|Lge6=GjS(<`ZmaVs1tV0EKmv$=m zB=3166Bv zKY!jG&?z-&z&MH(B>a~c2ys$(_8RB{c*A(q_2{5~fef~yk%jiLy&xXoL=Mf3%C-W8 zl@SOBe6qNJjv$klojByrv?zgV>2nZFtXhortzRZn*2fC8MwBGW!zYDce7o1Oj{rWL zTTWXc6(k(_{;);Mp9QA;tq$Jsi zB$;Y$lTPY4F^>EAIyVdrmLNeyo;+8@4HEr8xBwIq5JgGqlJXf}($=D_M3JcMzBO9U18-Bf{+GRXsOl1#iBf0b z3Po{eOTDi2hC_0&Th1gaLc~$TpNU{!t4iPeSZ_-`_wM65BO(A(io_`iK+ITCwT>N+ zV6g*ldv4{p5npI`?RxO))4qNB7|gu-qc?pu1l6DmM>L4a)!Vm^Hx3u@@y`Ac<;X9K z=u;4Y1O?!$tolny(1Ur@0t;vafWIRsC{o_pSqpr6yviC(S?KBTu)W7;=PGU{R(;4_ z=;>*Prc~l}ud>WO`9z z2R-RG-L;Sh`X-@dC@QX;vV@Z-4LS^2T6;)HOY11pkRRPx*jnNF2Ph-#0^A!Y;cRjr zVOYuC2m2xVAiWk~i#p|K^6m0v#H&Wr*}JAl|v$U z#A_JN&-d-P;_Yw}KnqbHp`7T&Li1ZH^H-`u#PpCDQl6v=ft31S+O%Mz3IpyO zNcYj)sxKdP_4IDOTIsVg>GGvZv+)EjjQt?V6NjD%uNG?j>=%nb zO}euv(-x%~$#EwyEQTjze(}K_D%Am?agh;IP9vDc%~PIKBnouM>AQ=_wX0I(MWVo$ z+j7e}*?oy4h_4R#7Z8;8!dwpSj&0lab3kT;DFLPEmw&H#E+Sg-@wkVbux>*u-;Mx8 z%X>96#e1`3uYUb(U?Zc_($o6^*{4UH$8b3Ef!LNc*FYf4IeX%_Q?lSn)dfuDK*~e8 z@5bZJEJ>=N3vYez(rdpEZT|&rGPPBL!pT=F)k%=+4eQsB$BBc~d4S%3SHHeUl;ww5 z%f(>Qz+N#|tsfc}=bbrGxO%9T)+qLY9Ufy$c%|s9YbswD=OlQ>bU&#l5DQuz7s|SQ zbgypQw8hS(DB# zJqB%WKDWK1I)~yx0ri#NbvlJB%)zAJUt3XLbzmT6lv}}BDEsLeo!!Ev5AC7+UeNt3YR*lnmkYsoU@V^Uukz&K?E?5xtN2Dm=(FC|JORY@|c; zF27N@PX-VwN;|YME5Eb8$P7g*0!ZQXC1L`G*Y^%!;Jr3% z5<2IshMiW3SkV=JOXR)J!G{Ir3w;f*U$}kT(D9r&t@Tsu?MOyO1mc)Q->O4IErAsm zF$(5J-D-#_7Jn{vI+-& z2t}^c8CZT^-a^XuPJJX?*8#DC@kt8#y_dDz&8t^)MK!`~QlJe>?4OvsLm?r%y!G`F z-K5tH9yF+s&S3q^H5AVgYs#JtCx!xombj%10(zH2R6(kDXCtErb2m}IIi8&IF8v<> z?0S(9O1QwigeKXLfc%U!OXzQ_^Lnqq^$O8qkLNRmTag3EiQUElq;h>`MXsp|b|r#1 z3_+5cTR%E;PuSvH-a$ti6&WPr_ zt7|Al2tYm{q7|nbtxkMl{aP=3g@8gc{OXytdNu>!ODDR}M+BX%2knH6+gMohee?dv z&Z@Ke*HMdM9Ybs8rHA?f^KI07bmp9+S{O2%4O_Nk^Ct8u?JF!867SH}Zz(t$o>Wtv z5I#UqMb7>?m})TMP;tWSun^5~E*$u(pI@T)mnE1tV5~`oKGkqBXUD8!?4#fHnVl4# z5!~8Kf8R_)ZAMFr-?r%6a)OnWS=2|tC8$Fy zKuW|W+*R}reIxQs0x9PvYFh7~?!=cAiV@e1Iom}^|B+ps<`6Qx*g5GY@PPW>$Hp%` zA86cg10cC*c>DC}bCM@zv3H0)=~;e;`7nK<%_`bsI{p+9JN6W4JLt`XDUPQfO6tVH z5f)dt96mM_NymvRh~~%P(t)ZV15ony{S&5=3u44j9V{8~ zwAIR&AK`|tHk`iT#+oC>rq_($v8KBm^e(Hm_uZL!s*ajX-m-K({RK}(VmWRYY)409 zPgnllw|0yjJ$h?oWF*#CN+A%SOMu8j?cZa!UgZT%j#ox&QuQ)SDB9`3s$*T%|0>>O zT)HYveWmk5{H53H*zB9`i>TZHMCD813q8G>zWunvW6abx9RrrE`r|@JeTZyQ3UB8)Au`uA%+@`7!38`4xtFn+J!re5 zhm9-GbefpfiJthvI^$%`RJfWWBwenku1Jvxy!sY5S8bS*LFcsRp}j`P=VOM1+N!_7 z_dB3{JA<-gRAcCrbZa2*bCB-5QShf%A;&Qy5xlzaT(-}L z)>KpUjy?s^co6+(7@?U|SrGChJ`Nmzs*&0aOFjiUsHs$1VB^z#s^51~S`nFODaBWW z827w7JsgV=34tY!q8~Ce_}<68N;;vAB+&~xS2&=}5233!CskO^%Z%_RY}^l5V??{i z0oJbjFPK=S4R4~jF~ukUoYdl^)l@yId2pu(Ym>)JFHi%Y>J>_#n=^H+KiQM+e^r?W2O?;b{M*1qI6R1vHsjSW3|nl)o(6o-+S7y zZTe=0wvNOJ#4k}I&O(DMVuX!(VGQe4&78E`=H3?3CK8k%hJfbb=g`XmqiqqZ7WURW z{X)lg>EnzG@mbrgd)s&I)hpGY`%{8;F2R;O$EX{$*idcQluBeys{y&+NXLlP8h|NVZ~< z0+9?xN$5Uk;Yeh0qXPPGLhdKQiTHQ+fiO38Q@Be)kO@2{->OccnZQjSzWPC!ctn39 z&A^>Z;H1YQ5vT=D?0(a=p#O#N)l}YzQc_GZLGaQMsqK7$+zljfhmNX1Q6_IqVD{)v z8xb>^nQf3z3I}Wv`8;?n>*J7eF}8LM33PCPYC2qdYygyyI4~k*&K2UG!)%SdxTi` zp3sL-7aT&Ug_B@N6d(o;y@XTKLwJCz3%}?P!pc2!0@mC=6)^y#f+x$ug>0aE%#=hEwl0Wi_uKc#rXSs(0mG zr_t>n`}#KgQC;oF46~p6jW^g`w=iRF!9x420B7^`!00@WMe*f_7fo1jZfx|f#OU2U zSM1K&Xdh6=-paC@&Zh=iUFvRVKkWA7AwIp`J9Si>*Yd*7l39xk6VKdU?C!bp;=XKe z2Pq<;bVMru*qSb28u9ZV|K8w-Ho-YLlcWamD+qiCwxTR=QLWBK^tRNS3M-525(o`| zPr@&V+3i00=Gh+>KB;e;|6Gtfxa&xaJ{b84sgI$LiAIe*jaNs4O^yOBx=VEA6qg&c z=j758`bVy~#JV80S$JlO5eQc+1g5xtIf`Ly>L2%NQ((;?aP zzP<{ws_RSh3QewRZ3WQl&T5r>eY_ zV+_|vesBk~prs^IKQ6i~sx^&1<*%j|H;tZaB7Z{@{UmvrqZsS`r8 zM+5U444WYOsJZ=vKp?a>rW}Ch(bd;~7jU`J4?kG**{u3WscxEh?83m;%dnX$jb@&* zD>appf4jK2NW}&c6cMZnJOL)~Y~dMzxU-6Z6iHnV;xl3+Ro!RQ{ zM{K9+f&tnpn?6$1o4p~m;m7<(wsv-5@19=KMP0n;`OR$^N8f#>O$OB35n@G`Pj4Ta z>_1AwSMu@0At58_D9qKVE$ zaw*WW$svJQ+_*LBvN*Xw1+3|0pCVRbBWF??!-Utr5)+9Ha zpLXnF%Ct= z#ePPX7cX33vV2|Hg{Y_RpiGhTpP7*%*gvjn$9hlw54Bev78WKn$Zr=Lh!C;7yj*I$ zaB%|r&iKATWM+iOMMP={?u-TRGGi05g%r(P{;jd%?YM3I6qEV@!s5M(0IJgft2R9< z$%+nw<#2DGRX?~&ssX4lPAC66LMNVatboWdIgmlGJ`bfsjbJrk$pV)ja|@#SZ?9KT zcN|G<_T*%@19Fvl0MiEaK@6HY>)1pgl8R^-%_a+fwIqRVLw*-qDuVlMl`CQ4ARoq3 zSItLm2Wnk#Skrg#+LY;ckzZ_b^Pfacb`V4%A~e(lApZD7Jwd7ut6LpbD4I4`jvQ_s z6qK9Pd%{WeCZiO?`jU{mHu_HSvCi=Z$$p=x3D3@sOAM_-FXn2a;6bJP>wH#B>D2bF?$Y_aMh%@ZVyNQQwiel2TMV1<>|#H^643Xg zJ+tcO*-J@XtcA(Rioh#mX?un&vl3lpP*4!Lx%!Vk-pT1zFHiliv0+?KIf(P&vuCGZ zUC9sTmduHjTN*ahz?56s+Jg5VR= z+ug#=O1r-#;Y5Cm-#r;MqwDDWl}{c&?u=a}{n0Trj86<(bft6G`Nmy4O)?ppztYs? zg@a6u6WqznzY_3k3_qj~p3`9x<-pZPI5E$_x4O=8fm`oWa<; ziV82Ix5@Qh8>uT*rpw2D`@4^8>@Ma=hhkV6`g_8JJk&udzP~=U;FiC>8-~tW_A%c91G{jD+ zTo14$)l~$64xXErBsd5Tfz($=M@Q|)A4N1>n-6K&npD3quDMIlDp5SLXl1jtBOv>{ zio(M-Ssjmx8bcpZ%i+UU30;-s;{!S-?E_RH0_E|Z8Kgw&z^p)BR1Cg}Uo?qm`$XD% z(u^E9V0O8Xl2UC2KFjfR%}hE`e5S9f-PiTWTO`hiH5 zZ;QWg(xi-#RGXq{;?V66+_Q;s5ZtWkmMsb2H$W^CKO{w^g3f6c@_a>MM(ncVufL** z+KLccX4Zx`EU4ts1S&$`-k;lFU0r?mxh?YJlXJFX-TT2s*+<(-?U|!@xqqR)dqdrC z2k&hRer~5`)Aj=`L0zP1`kgdT7R)OmGSX)J`2BRzrC=;FICvP9EhhKx0q?hRoB;tU zwb`2C_sfddyDkoqk)5e(={a+Cp;6;Os`80HTjK2&L9OYpwJ(?fn=UW_b6s?Q}p z2Uhcbd%mF*UK56t5ky{fkAq~kFM>eOEX4U4uK09R%5rg4N)=|)AKsq9oRj0XunXbI zf~GDjP)7%HjaY+-3atMQ!h?d65+C!Y4|Kjc8{dR`yp@2ma<3F4$h#6NF6NTu&`{N3 z3E%-~A|wVWf&?O7uZ~@j5DS$6Oto&$o@2Kdec08$*;)a5sc>|KX_UMlszR_N*iNB( zy`Jx$C8CNwsEo1Y2#tf;4r)lvX%_eTL4qAWq}1HvxuNuGPDVM+P;Svv|g~_m{-}${nU3{e>|VACzf0u z25a8?)e{7lB|}6-?|@yiwXpC*)N`<+q9SOe+td43{EU-6U65Wrn0NvbJ94am@`+f zspFHPFUKMg_UFRHF*7G%&Dyn*B!?o?!M1q-sRX^*cTYo9P(;Vl5kPiT$3^`ki8)mv zWI)}iEB@31F+lj^3}Tmfy(BhVrgvno;)ipd~#B)V~(QZj#_wY7Cf zi>@XwDZsd8t8HdAd-h>Ly+}aE2?oMvN)y-&VF))XP6nt|V)P&gI9Gsw6Xi}gUlW6 zb1M6IMHueC|Gilh|2l;Ke8pI5RGoM%WzUBO R?PLLzqsERr^6RwU{~Oe(>lpw5 diff --git a/docs/reference/federation/img/remote_user_handle_lookup.swimlanes.io.txt b/docs/reference/federation/img/remote_user_handle_lookup.swimlanes.io.txt deleted file mode 100644 index cdd32361631..00000000000 --- a/docs/reference/federation/img/remote_user_handle_lookup.swimlanes.io.txt +++ /dev/null @@ -1,21 +0,0 @@ -// copy the following to use with https://swimlanes.io - -title: PR #1319: remote user handle lookup - -Wire client -> brig@A: handle=alice domain=example.com - -brig@A -> federator@A: Outward.call(FederatedRequest(example.com, Request(..))) - -note federator@A,federator@B: In the future, requests between backends here should be using some server2server authentication and also make use of an authorization strategy (open federation, allow list, ...). - -federator@A -> federator@B: Inward.call(Request(brig, "/handle/alice")) - -federator@B -> brig@B: Request(/handle/alice) - -brig@B -> federator@B: Response - -federator@B -> federator@A: Response - -federator@A -> brig@A: Response - -brig@A -> Wire client: userId=1234 domain=example.com diff --git a/docs/reference/federation/pull-requests/1319_initial_federation_request_across_backends.md b/docs/reference/federation/pull-requests/1319_initial_federation_request_across_backends.md deleted file mode 100644 index e7277539766..00000000000 --- a/docs/reference/federation/pull-requests/1319_initial_federation_request_across_backends.md +++ /dev/null @@ -1,30 +0,0 @@ -This PR #1319 is one small piece in the context of Federation, namely code for the first few bytes to travel from one backend to another backend. The example implemented here is exact handle search as per https://wearezeta.atlassian.net/browse/SQCORE-108 - -For general context about federation design, see (sorry non-Wire employees, this documentation will eventually be made available) https://github.com/wearezeta/documentation/blob/master/topics/federation/federation-design.md - -This introduces the [mu-haskell](https://higherkindness.io/mu-haskell/) set of libraries as a new stack dependency to gain support in wire-server for http2 / GRPC (based on protobuf). - -We make use of GRPC as a protocol as a new intra-service call internally from `brig` to `federator` (for the reverse flow from `federator` to `brig` we still use a REST API for the time being to not change too much at once), and also as a protocol between backends. - -The following networking flow is implemented: - -(to modify this diagram, see the swimlanes.io [source](../img/remote_user_handle_lookup.swimlanes.io.txt)) - -![remote_user_handle_lookup](../img/remote_user_handle_lookup.png) - -1. A component (e.g. 'brig') will send some data of type 'FederatedRequest' to -the 'federator' server (more precisely: the 'Outward' service part of the federator) within a same private network. -2. The federator will use the domain from the 'FederatedRequest' to discover -where to send some data of type 'Request' to. -3. On the other side, a publicly exposed 'Inward' service (also co-hosted on the -federator) will turn the received 'Request' into a 'Response' by making a call to a -component (e.g. brig) on its private network. - -See also [wire-api-federation/proto/router.proto](../../../../libs/wire-api-federation/proto/router.proto) for details of the grpc protocol. - -Note: Server-server authentication is not yet implemented, so this code uses plain TCP between different backends at this point. This should be okay for the time being, since: -- the federator component is disabled by default in the wire-server helm chart and won't be "accidentally" installed -- we do not, and do not plan to run the federator in staging or production for the time being until much more of federation has been implemented: any request from brig to federator thus always fails with a 404 or other error client-side at this point. -- (instead we will have separate federation playground servers) - -The core types allowing an easy extension of this code to support other requests and endpoints than the handle lookup can be found in libs/wire-server-api (notably the `proto/router.proto` file). diff --git a/hack/bin/cabal-run-tests.sh b/hack/bin/cabal-run-tests.sh index 7364ea40fa2..a9b17b4c462 100755 --- a/hack/bin/cabal-run-tests.sh +++ b/hack/bin/cabal-run-tests.sh @@ -11,4 +11,8 @@ pkgName=${1:-Please specify package name} pkgDir=$(find "$TOP_LEVEL" -name "$pkgName.cabal" | grep -v dist-newstyle | head -1 | xargs -n 1 dirname) cd "$pkgDir" -cabal-plan list-bins "$pkgName"':test:*' | awk '{print $2}' | xargs --no-run-if-empty -n 1 bash -c +test_suites=$(cabal-plan list-bins "$pkgName"':test:*' | awk '{print $2}') + +for test_suite in $test_suites; do + $test_suite "${@:2}" +done diff --git a/hack/federation/grpcurlhandle.sh b/hack/federation/grpcurlhandle.sh deleted file mode 100755 index e3f47314bc9..00000000000 --- a/hack/federation/grpcurlhandle.sh +++ /dev/null @@ -1,46 +0,0 @@ -#!/usr/bin/env bash - -# Usage: -# -# First, run services (including nginz) locally: -# -# export INTEGRATION_USE_NGINZ=1; ./services/start-services-only.sh -# -# Then, run this command for user search (ideally on a handle that exists) -# -# -# -handle="pyaewrqxggbtbvzdsubkl" # change this to a valid handle in your local database - -command -v grpcurl >/dev/null 2>&1 || { - echo >&2 "grpcurl is not installed, aborting. Maybe try ' nix-env -iA nixpkgs.grpcurl '?" - exit 1 -} - -path=$(echo -n federation/get-user-by-handle | base64) -body=$(echo -n "\"$handle\"" | base64) - -TOP_LEVEL="$(cd "$(dirname "${BASH_SOURCE[0]}")/../.." && pwd)" - -function getHandle() { - echo "" - echo "===> getHandle: $1" - if [ -z "$SERVERNAME" ]; then - AUTHORITY="" - else - AUTHORITY="-authority $SERVERNAME" - fi - set -x - grpcurl -d @ -format json $AUTHORITY $MODE -import-path "${TOP_LEVEL}/libs/wire-api-federation/proto/" -proto router.proto "$HOST:$PORT" wire.federator.Inward/call </dev/null # stop outputting commands and don't print the set +x line - echo "===|" - echo -} - -HOST="localhost" -SERVERNAME="federator.integration.example.com" -PORT=8443 -MODE="-cacert ${TOP_LEVEL}/services/nginz/integration-test/conf/nginz/integration-ca.pem" -getHandle "local" diff --git a/hack/federation/python-client/.gitignore b/hack/federation/python-client/.gitignore deleted file mode 100644 index 8006d530463..00000000000 --- a/hack/federation/python-client/.gitignore +++ /dev/null @@ -1,3 +0,0 @@ -__pycache__/ -router_pb2.py -router_pb2_grpc.py diff --git a/hack/federation/python-client/README.md b/hack/federation/python-client/README.md deleted file mode 100644 index f9d1f0e6faa..00000000000 --- a/hack/federation/python-client/README.md +++ /dev/null @@ -1,43 +0,0 @@ -Install python dependencies and generate python files from proto: - -``` -poetry install -poetry run python -m grpc_tools.protoc -I../../../libs/wire-api-federation/proto --python_out=. --grpc_python_out=. ../../../libs/wire-api-federation/proto/router.proto -``` - -Run services locally: - -``` -export INTEGRATION_USE_NGINZ=1 -../../../services/start-services-only.sh -``` - -Run example python client to make a grpc request to federator (which will redirect it to brig): - -``` -poetry run python client.py -``` - -expected output should be: - -``` -starting client... -request: path: "federation/get-user-by-handle" -body: "\"pyaewrqxggbtbvzdsubkl\"" -originDomain: "python.example.com" - -json reponse: - { - "handle": "pyaewrqxggbtbvzdsubkl", - "qualified_id": { - "domain": "example.com", - "id": "0f3880e6-5fb5-4c3d-963d-8ea36e15717c" - }, - "accent_id": 0, - "picture": [], - "legalhold_status": "no_consent", - "name": "\u7985\u9a71\ud4d1\u7485", - "id": "0f3880e6-5fb5-4c3d-963d-8ea36e15717c", - "assets": [] -} -``` diff --git a/hack/federation/python-client/client.py b/hack/federation/python-client/client.py deleted file mode 100644 index cd67d7e43ee..00000000000 --- a/hack/federation/python-client/client.py +++ /dev/null @@ -1,29 +0,0 @@ -import grpc -import json - -from router_pb2 import * -import router_pb2_grpc - -# make sure to run ./services/start-services-only.sh first to have federator and brig up! -print("starting client...") - -channel = grpc.insecure_channel('localhost:8098') # public-facing federator port -stub = router_pb2_grpc.InwardStub(channel) - -def handle_search(handle): - return Request( - path="federation/get-user-by-handle".encode("utf-8"), - body=('"' + handle + '"').encode("utf-8"), - originDomain="python.example.com", - component=Brig) - -req = handle_search("pyaewrqxggbtbvzdsubkl") - -print("request: ", req) - -response = stub.call(req) -try: - jsonresponse = json.dumps(json.loads(response.body.decode('utf-8')), indent=2) - print("json reponse:\n", jsonresponse) -except: - print("non-json response:\n", response) diff --git a/hack/federation/python-client/poetry.lock b/hack/federation/python-client/poetry.lock deleted file mode 100644 index d73be5fe9bf..00000000000 --- a/hack/federation/python-client/poetry.lock +++ /dev/null @@ -1,403 +0,0 @@ -[[package]] -category = "main" -description = "Disable App Nap on macOS >= 10.9" -marker = "sys_platform == \"darwin\"" -name = "appnope" -optional = false -python-versions = "*" -version = "0.1.2" - -[[package]] -category = "main" -description = "Specifications for callback functions passed in to an API" -name = "backcall" -optional = false -python-versions = "*" -version = "0.2.0" - -[[package]] -category = "main" -description = "Cross-platform colored terminal text." -marker = "sys_platform == \"win32\"" -name = "colorama" -optional = false -python-versions = ">=2.7, !=3.0.*, !=3.1.*, !=3.2.*, !=3.3.*, !=3.4.*" -version = "0.4.4" - -[[package]] -category = "main" -description = "Decorators for Humans" -name = "decorator" -optional = false -python-versions = ">=2.6, !=3.0.*, !=3.1.*" -version = "4.4.2" - -[[package]] -category = "main" -description = "HTTP/2-based RPC framework" -name = "grpcio" -optional = false -python-versions = "*" -version = "1.35.0" - -[package.dependencies] -six = ">=1.5.2" - -[package.extras] -protobuf = ["grpcio-tools (>=1.35.0)"] - -[[package]] -category = "main" -description = "Protobuf code generator for gRPC" -name = "grpcio-tools" -optional = false -python-versions = "*" -version = "1.35.0" - -[package.dependencies] -grpcio = ">=1.35.0" -protobuf = ">=3.5.0.post1,<4.0dev" -setuptools = "*" - -[[package]] -category = "main" -description = "IPython: Productive Interactive Computing" -name = "ipython" -optional = false -python-versions = ">=3.7" -version = "7.20.0" - -[package.dependencies] -appnope = "*" -backcall = "*" -colorama = "*" -decorator = "*" -jedi = ">=0.16" -pexpect = ">4.3" -pickleshare = "*" -prompt-toolkit = ">=2.0.0,<3.0.0 || >3.0.0,<3.0.1 || >3.0.1,<3.1.0" -pygments = "*" -setuptools = ">=18.5" -traitlets = ">=4.2" - -[package.extras] -all = ["Sphinx (>=1.3)", "ipykernel", "ipyparallel", "ipywidgets", "nbconvert", "nbformat", "nose (>=0.10.1)", "notebook", "numpy (>=1.14)", "pygments", "qtconsole", "requests", "testpath"] -doc = ["Sphinx (>=1.3)"] -kernel = ["ipykernel"] -nbconvert = ["nbconvert"] -nbformat = ["nbformat"] -notebook = ["notebook", "ipywidgets"] -parallel = ["ipyparallel"] -qtconsole = ["qtconsole"] -test = ["nose (>=0.10.1)", "requests", "testpath", "pygments", "nbformat", "ipykernel", "numpy (>=1.14)"] - -[[package]] -category = "main" -description = "Vestigial utilities from IPython" -name = "ipython-genutils" -optional = false -python-versions = "*" -version = "0.2.0" - -[[package]] -category = "main" -description = "An autocompletion tool for Python that can be used for text editors." -name = "jedi" -optional = false -python-versions = ">=3.6" -version = "0.18.0" - -[package.dependencies] -parso = ">=0.8.0,<0.9.0" - -[package.extras] -qa = ["flake8 (3.8.3)", "mypy (0.782)"] -testing = ["Django (<3.1)", "colorama", "docopt", "pytest (<6.0.0)"] - -[[package]] -category = "main" -description = "A Python Parser" -name = "parso" -optional = false -python-versions = ">=3.6" -version = "0.8.1" - -[package.extras] -qa = ["flake8 (3.8.3)", "mypy (0.782)"] -testing = ["docopt", "pytest (<6.0.0)"] - -[[package]] -category = "main" -description = "Pexpect allows easy control of interactive console applications." -marker = "sys_platform != \"win32\"" -name = "pexpect" -optional = false -python-versions = "*" -version = "4.8.0" - -[package.dependencies] -ptyprocess = ">=0.5" - -[[package]] -category = "main" -description = "Tiny 'shelve'-like database with concurrency support" -name = "pickleshare" -optional = false -python-versions = "*" -version = "0.7.5" - -[[package]] -category = "main" -description = "Library for building powerful interactive command lines in Python" -name = "prompt-toolkit" -optional = false -python-versions = ">=3.6.1" -version = "3.0.16" - -[package.dependencies] -wcwidth = "*" - -[[package]] -category = "main" -description = "Protocol Buffers" -name = "protobuf" -optional = false -python-versions = "*" -version = "3.14.0" - -[package.dependencies] -six = ">=1.9" - -[[package]] -category = "main" -description = "Run a subprocess in a pseudo terminal" -marker = "sys_platform != \"win32\"" -name = "ptyprocess" -optional = false -python-versions = "*" -version = "0.7.0" - -[[package]] -category = "main" -description = "Pygments is a syntax highlighting package written in Python." -name = "pygments" -optional = false -python-versions = ">=3.5" -version = "2.7.4" - -[[package]] -category = "main" -description = "Python 2 and 3 compatibility utilities" -name = "six" -optional = false -python-versions = ">=2.7, !=3.0.*, !=3.1.*, !=3.2.*" -version = "1.15.0" - -[[package]] -category = "main" -description = "Traitlets Python configuration system" -name = "traitlets" -optional = false -python-versions = ">=3.7" -version = "5.0.5" - -[package.dependencies] -ipython-genutils = "*" - -[package.extras] -test = ["pytest"] - -[[package]] -category = "main" -description = "Measures the displayed width of unicode strings in a terminal" -name = "wcwidth" -optional = false -python-versions = "*" -version = "0.2.5" - -[metadata] -content-hash = "d2b3bd7740916466586fd07c5fe115152e9f580b9c89ccb26f2fa38420aa163f" -lock-version = "1.0" -python-versions = "^3.8" - -[metadata.files] -appnope = [ - {file = "appnope-0.1.2-py2.py3-none-any.whl", hash = "sha256:93aa393e9d6c54c5cd570ccadd8edad61ea0c4b9ea7a01409020c9aa019eb442"}, - {file = "appnope-0.1.2.tar.gz", hash = "sha256:dd83cd4b5b460958838f6eb3000c660b1f9caf2a5b1de4264e941512f603258a"}, -] -backcall = [ - {file = "backcall-0.2.0-py2.py3-none-any.whl", hash = "sha256:fbbce6a29f263178a1f7915c1940bde0ec2b2a967566fe1c65c1dfb7422bd255"}, - {file = "backcall-0.2.0.tar.gz", hash = "sha256:5cbdbf27be5e7cfadb448baf0aa95508f91f2bbc6c6437cd9cd06e2a4c215e1e"}, -] -colorama = [ - {file = "colorama-0.4.4-py2.py3-none-any.whl", hash = "sha256:9f47eda37229f68eee03b24b9748937c7dc3868f906e8ba69fbcbdd3bc5dc3e2"}, - {file = "colorama-0.4.4.tar.gz", hash = "sha256:5941b2b48a20143d2267e95b1c2a7603ce057ee39fd88e7329b0c292aa16869b"}, -] -decorator = [ - {file = "decorator-4.4.2-py2.py3-none-any.whl", hash = "sha256:41fa54c2a0cc4ba648be4fd43cff00aedf5b9465c9bf18d64325bc225f08f760"}, - {file = "decorator-4.4.2.tar.gz", hash = "sha256:e3a62f0520172440ca0dcc823749319382e377f37f140a0b99ef45fecb84bfe7"}, -] -grpcio = [ - {file = "grpcio-1.35.0-cp27-cp27m-macosx_10_10_x86_64.whl", hash = "sha256:95cc4d2067deced18dc807442cf8062a93389a86abf8d40741120054389d3f29"}, - {file = "grpcio-1.35.0-cp27-cp27m-manylinux2010_i686.whl", hash = "sha256:d186a0ce291f4386e28a7042ec31c85250b0c2e25d2794b87fa3c15ff473c46c"}, - {file = "grpcio-1.35.0-cp27-cp27m-manylinux2010_x86_64.whl", hash = "sha256:c8d0a6a58a42275c6cb616e7cb9f9fcf5eba1e809996546e561cd818b8f7cff7"}, - {file = "grpcio-1.35.0-cp27-cp27m-win32.whl", hash = "sha256:8d08f90d72a8e8d9af087476337da76d26749617b0a092caff4e684ce267af21"}, - {file = "grpcio-1.35.0-cp27-cp27m-win_amd64.whl", hash = "sha256:0072ec4563ab4268c4c32e936955085c2d41ea175b662363496daedd2273372c"}, - {file = "grpcio-1.35.0-cp27-cp27mu-linux_armv7l.whl", hash = "sha256:aca45d2ccb693c9227fbf21144891422a42dc4b76b52af8dd1d4e43afebe321d"}, - {file = "grpcio-1.35.0-cp27-cp27mu-manylinux2010_i686.whl", hash = "sha256:87147b1b306c88fe7dca7e3dff8aefd1e63d6aed86e224f9374ddf283f17d7f1"}, - {file = "grpcio-1.35.0-cp27-cp27mu-manylinux2010_x86_64.whl", hash = "sha256:22edfc278070d54f3ab7f741904e09155a272fe934e842babbf84476868a50de"}, - {file = "grpcio-1.35.0-cp35-cp35m-linux_armv7l.whl", hash = "sha256:f3654a52f72ba28953dbe2e93208099f4903f4b3c07dc7ff4db671c92968111d"}, - {file = "grpcio-1.35.0-cp35-cp35m-macosx_10_10_intel.whl", hash = "sha256:dc2589370ef84eb1cc53530070d658a7011d2ee65f18806581809c11cd016136"}, - {file = "grpcio-1.35.0-cp35-cp35m-manylinux2010_i686.whl", hash = "sha256:f0c27fd16582a303e5baf6cffd9345c9ac5f855d69a51232664a0b888a77ba80"}, - {file = "grpcio-1.35.0-cp35-cp35m-manylinux2010_x86_64.whl", hash = "sha256:b2985f73611b637271b00d9c4f177e65cc3193269bc9760f16262b1a12757265"}, - {file = "grpcio-1.35.0-cp35-cp35m-manylinux2014_i686.whl", hash = "sha256:acb489b7aafdcf960f1a0000a1f22b45e5b6ccdf8dba48f97617d627f4133195"}, - {file = "grpcio-1.35.0-cp35-cp35m-manylinux2014_x86_64.whl", hash = "sha256:16fd33030944672e49e0530dec2c60cd4089659ccdf327e99569b3b29246a0b6"}, - {file = "grpcio-1.35.0-cp35-cp35m-win32.whl", hash = "sha256:1757e81c09132851e85495b802fe4d4fbef3547e77fa422a62fb4f7d51785be0"}, - {file = "grpcio-1.35.0-cp35-cp35m-win_amd64.whl", hash = "sha256:35b72884e09cbc46c564091f4545a39fa66d132c5676d1a6e827517fff47f2c1"}, - {file = "grpcio-1.35.0-cp36-cp36m-linux_armv7l.whl", hash = "sha256:17940a7dc461066f28816df48be44f24d3b9f150db344308ee2aeae033e1af0b"}, - {file = "grpcio-1.35.0-cp36-cp36m-macosx_10_10_x86_64.whl", hash = "sha256:75ea903edc42a8c6ec61dbc5f453febd79d8bdec0e1bad6df7088c34282e8c42"}, - {file = "grpcio-1.35.0-cp36-cp36m-manylinux2010_i686.whl", hash = "sha256:b180a3ec4a5d6f96d3840c83e5f8ab49afac9fa942921e361b451d7a024efb00"}, - {file = "grpcio-1.35.0-cp36-cp36m-manylinux2010_x86_64.whl", hash = "sha256:e163c27d2062cd3eb07057f23f8d1330925beaba16802312b51b4bad33d74098"}, - {file = "grpcio-1.35.0-cp36-cp36m-manylinux2014_i686.whl", hash = "sha256:764b50ba1a15a2074cdd1a841238f2dead0a06529c495a46821fae84cb9c7342"}, - {file = "grpcio-1.35.0-cp36-cp36m-manylinux2014_x86_64.whl", hash = "sha256:088c8bea0f6b596937fefacf2c8df97712e7a3dd49496975049cc95dbf02af1a"}, - {file = "grpcio-1.35.0-cp36-cp36m-win32.whl", hash = "sha256:1aa53f82362c7f2791fe0cdd9a3b3aec325c11d8f0dfde600f91907dfaa8546b"}, - {file = "grpcio-1.35.0-cp36-cp36m-win_amd64.whl", hash = "sha256:efb3d67405eb8030db6f27920b4be023fabfb5d4e09c34deab094a7c473a5472"}, - {file = "grpcio-1.35.0-cp37-cp37m-macosx_10_10_x86_64.whl", hash = "sha256:44aaa6148d18a8e836f99dadcdec17b27bc7ec0995b2cc12c94e61826040ec90"}, - {file = "grpcio-1.35.0-cp37-cp37m-manylinux2010_i686.whl", hash = "sha256:18ad7644e23757420ea839ac476ef861e4f4841c8566269b7c91c100ca1943b3"}, - {file = "grpcio-1.35.0-cp37-cp37m-manylinux2010_x86_64.whl", hash = "sha256:859a0ceb23d7189362cc06fe7e906e9ed5c7a8f3ac960cc04ce13fe5847d0b62"}, - {file = "grpcio-1.35.0-cp37-cp37m-manylinux2014_i686.whl", hash = "sha256:3e7d4428ed752fdfe2dddf2a404c93d3a2f62bf4b9109c0c10a850c698948891"}, - {file = "grpcio-1.35.0-cp37-cp37m-manylinux2014_x86_64.whl", hash = "sha256:a36151c335280b09afd5123f3b25085027ae2b10682087a4342fb6f635b928fb"}, - {file = "grpcio-1.35.0-cp37-cp37m-win32.whl", hash = "sha256:dfecb2acd3acb8bb50e9aa31472c6e57171d97c1098ee67cd283a6fe7d56a926"}, - {file = "grpcio-1.35.0-cp37-cp37m-win_amd64.whl", hash = "sha256:e87e55fba98ebd7b4c614dcef9940dc2a7e057ad8bba5f91554934d47319a35b"}, - {file = "grpcio-1.35.0-cp38-cp38-macosx_10_10_x86_64.whl", hash = "sha256:da44bf613eed5d9e8df0785463e502a416de1be6e4ac31edbe99c9111abaed5f"}, - {file = "grpcio-1.35.0-cp38-cp38-manylinux2010_i686.whl", hash = "sha256:9e503eaf853199804a954dc628c5207e67d6c7848dcba42a997fbe718618a2b1"}, - {file = "grpcio-1.35.0-cp38-cp38-manylinux2010_x86_64.whl", hash = "sha256:6ba3d7acf70acde9ce27e22921db921b84a71be578b32739536c32377b65041a"}, - {file = "grpcio-1.35.0-cp38-cp38-manylinux2014_i686.whl", hash = "sha256:048c01d1eb5c2ae7cba2254b98938d2fc81f6dc10d172d9261d65266adb0fdb3"}, - {file = "grpcio-1.35.0-cp38-cp38-manylinux2014_x86_64.whl", hash = "sha256:efd896e8ca7adb2654cf014479a5e1f74e4f776b6b2c0fbf95a6c92787a6631a"}, - {file = "grpcio-1.35.0-cp38-cp38-win32.whl", hash = "sha256:8a29a26b9f39701ce15aa1d5aa5e96e0b5f7028efe94f95341a4ed8dbe4bed78"}, - {file = "grpcio-1.35.0-cp38-cp38-win_amd64.whl", hash = "sha256:aea3d592a7ece84739b92d212cd16037c51d84a259414f64b51c14e946611f3d"}, - {file = "grpcio-1.35.0-cp39-cp39-macosx_10_10_x86_64.whl", hash = "sha256:2f8e8d35d4799aa1627a212dbe8546594abf4064056415c31bd1b3b8f2a62027"}, - {file = "grpcio-1.35.0-cp39-cp39-manylinux2010_i686.whl", hash = "sha256:9f0da13b215068e7434b161a35d0b4e92140ffcfa33ddda9c458199ea1d7ce45"}, - {file = "grpcio-1.35.0-cp39-cp39-manylinux2010_x86_64.whl", hash = "sha256:7ae408780b79c9b9b91a2592abd1d7abecd05675d988ea75038580f420966b59"}, - {file = "grpcio-1.35.0-cp39-cp39-manylinux2014_i686.whl", hash = "sha256:0f714e261e1d63615476cda4ee808a79cca62f8f09e2943c136c2f87ec5347b1"}, - {file = "grpcio-1.35.0-cp39-cp39-manylinux2014_x86_64.whl", hash = "sha256:7ee7d54da9d176d3c9a0f47c04d7ff6fdc6ee1c17643caff8c33d6c8a70678a4"}, - {file = "grpcio-1.35.0-cp39-cp39-win32.whl", hash = "sha256:94c3b81089a86d3c5877d22b07ebc66b5ed1d84771e24b001844e29a5b6178dd"}, - {file = "grpcio-1.35.0-cp39-cp39-win_amd64.whl", hash = "sha256:399ee377b312ac652b07ef4365bbbba009da361fa7708c4d3d4ce383a1534ea7"}, - {file = "grpcio-1.35.0.tar.gz", hash = "sha256:7bd0ebbb14dde78bf66a1162efd29d3393e4e943952e2f339757aa48a184645c"}, -] -grpcio-tools = [ - {file = "grpcio-tools-1.35.0.tar.gz", hash = "sha256:9e2a41cba9c5a20ae299d0fdd377fe231434fa04cbfbfb3807293c6ec10b03cf"}, - {file = "grpcio_tools-1.35.0-cp27-cp27m-macosx_10_10_x86_64.whl", hash = "sha256:cfa49e6d62b313862a6007ae02016bd89a2fa184b0aab0d0e524cb24ecc2fdb4"}, - {file = "grpcio_tools-1.35.0-cp27-cp27m-manylinux2010_i686.whl", hash = "sha256:f66cd905ffcbe2294c9dee6d0de8064c3a49861a9b1770c18cb8a15be3bc0da5"}, - {file = "grpcio_tools-1.35.0-cp27-cp27m-manylinux2010_x86_64.whl", hash = "sha256:56663ba4a49ca585e4333dfebc5ed7e91ad3d75b838aced4f922fb4e365376cc"}, - {file = "grpcio_tools-1.35.0-cp27-cp27m-win32.whl", hash = "sha256:252bfaa0004d80d927a77998c8b3a81fb47620e41af1664bdba8837d722c4ead"}, - {file = "grpcio_tools-1.35.0-cp27-cp27m-win_amd64.whl", hash = "sha256:ffa66fc4e80aff4f68599e786aa3295f4a0d6761ed63d75c32261f5de77aa0fd"}, - {file = "grpcio_tools-1.35.0-cp27-cp27mu-linux_armv7l.whl", hash = "sha256:3cea2d07343801cb2a0d2f71fe7d6d7ffa6fe8fc0e1f6243c6867d0bb04557a1"}, - {file = "grpcio_tools-1.35.0-cp27-cp27mu-manylinux2010_i686.whl", hash = "sha256:15c37528936774d8f734d75540848134fb5710ca27801ce4ac73c8a6cca0494e"}, - {file = "grpcio_tools-1.35.0-cp27-cp27mu-manylinux2010_x86_64.whl", hash = "sha256:f3861211a450a312b7645d4eaf16c78f1d9e896e58a8c3be871f5881362d3fee"}, - {file = "grpcio_tools-1.35.0-cp35-cp35m-linux_armv7l.whl", hash = "sha256:5fdb6a65f66ee6cdc49455ea03ca435ae86ef1869dc929a8652cc19b5f950d22"}, - {file = "grpcio_tools-1.35.0-cp35-cp35m-macosx_10_10_intel.whl", hash = "sha256:8bfd05f26af9ea069f2f3c48740a315470fc4a434189544fea3b3508b71be9a0"}, - {file = "grpcio_tools-1.35.0-cp35-cp35m-manylinux2010_i686.whl", hash = "sha256:f7074cfd79989424e4bd903ff5618c1420a7c81ad97836256f3927447b74c027"}, - {file = "grpcio_tools-1.35.0-cp35-cp35m-manylinux2010_x86_64.whl", hash = "sha256:adea0bd93978284f1590a3880d79621881f7029b2fac330f64f491af2b554707"}, - {file = "grpcio_tools-1.35.0-cp35-cp35m-manylinux2014_i686.whl", hash = "sha256:b23e0a64cdbf4c3bcdf8e6ad0cdd8b8a582a4c50d5ed4eddc4c81dc8d5ba0c60"}, - {file = "grpcio_tools-1.35.0-cp35-cp35m-manylinux2014_x86_64.whl", hash = "sha256:7cc68c42bcbebd76731686f22870930f110309e1e69244df428f8fb161b7645b"}, - {file = "grpcio_tools-1.35.0-cp35-cp35m-win32.whl", hash = "sha256:aa9cb65231a7efd77e83e149b1905335eda1bbadd301dd1bffcbfea69fd5bd56"}, - {file = "grpcio_tools-1.35.0-cp35-cp35m-win_amd64.whl", hash = "sha256:11e6dffd2e58737ade63a00a51da83b474b5740665914103f003049acff5be8e"}, - {file = "grpcio_tools-1.35.0-cp36-cp36m-linux_armv7l.whl", hash = "sha256:59d80997e780dc52911e263e30ca2334e7b3bd12c10dc81625dcc34273fa744b"}, - {file = "grpcio_tools-1.35.0-cp36-cp36m-macosx_10_10_x86_64.whl", hash = "sha256:179b2eb274d8c29e1e18c21fb69c5101e3196617c7abb193a80e194ea9b274be"}, - {file = "grpcio_tools-1.35.0-cp36-cp36m-manylinux2010_i686.whl", hash = "sha256:1687b0033beff82ac35f14fbbd5e7eb0cab39e60f8be0a25a7f4ba92d66578c8"}, - {file = "grpcio_tools-1.35.0-cp36-cp36m-manylinux2010_x86_64.whl", hash = "sha256:9e956751b1b96ce343088550d155827f8312d85f09067f6ede0a4778273b787b"}, - {file = "grpcio_tools-1.35.0-cp36-cp36m-manylinux2014_i686.whl", hash = "sha256:4ca85f9deee58473c017ee62aaa8c12dfda223eeabed5dd013c009af275bc4f2"}, - {file = "grpcio_tools-1.35.0-cp36-cp36m-manylinux2014_x86_64.whl", hash = "sha256:853d030ff74ce90244bb77c5a8d5c2b2d84b24df477fc422d44fa81d512124d6"}, - {file = "grpcio_tools-1.35.0-cp36-cp36m-win32.whl", hash = "sha256:add160d4697a5366ee1420b59621bde69a3eaaba35170e60bd376f0ea6e24fe5"}, - {file = "grpcio_tools-1.35.0-cp36-cp36m-win_amd64.whl", hash = "sha256:dbaaad0132a9e70439e93d26611443ee3aaaa62547b7d18655ac754b4984ea25"}, - {file = "grpcio_tools-1.35.0-cp37-cp37m-macosx_10_10_x86_64.whl", hash = "sha256:bbc6986e29ab3bb39db9a0e31cdbb0ced80cead2ef0453c40dfdfacbab505950"}, - {file = "grpcio_tools-1.35.0-cp37-cp37m-manylinux2010_i686.whl", hash = "sha256:8631df0e357b28da4ef617306a08f70c21cf85c049849f4a556b95069c146d61"}, - {file = "grpcio_tools-1.35.0-cp37-cp37m-manylinux2010_x86_64.whl", hash = "sha256:a6e2b07dbe25c6022eeae972b4eee2058836dea345a3253082524240a00daa9f"}, - {file = "grpcio_tools-1.35.0-cp37-cp37m-manylinux2014_i686.whl", hash = "sha256:30f83ccc6d09be07d7f15d05f29acd5017140f330ba3a218ae7b7e19db02bda6"}, - {file = "grpcio_tools-1.35.0-cp37-cp37m-manylinux2014_x86_64.whl", hash = "sha256:88184383f24af8f8cbbb4020846af53634d8632b486479a3b98ea29c1470372e"}, - {file = "grpcio_tools-1.35.0-cp37-cp37m-win32.whl", hash = "sha256:579cf4538d8ec25314c45ef84bb140fad8888446ed7a69913965fd7d9bc188d5"}, - {file = "grpcio_tools-1.35.0-cp37-cp37m-win_amd64.whl", hash = "sha256:9203e0105db476131f32ff3c3213b5aa6b77b25553ffe0d09d973913b2320856"}, - {file = "grpcio_tools-1.35.0-cp38-cp38-macosx_10_10_x86_64.whl", hash = "sha256:c910dec8903fb9d16fd1b111de57401a46e4d5f74c6d009a12a945d696603eb0"}, - {file = "grpcio_tools-1.35.0-cp38-cp38-manylinux2010_i686.whl", hash = "sha256:cc9bcd34a653c2353dd43fc395ceb560271551f2fae30bcafede2e4ad0c101c4"}, - {file = "grpcio_tools-1.35.0-cp38-cp38-manylinux2010_x86_64.whl", hash = "sha256:4241301b8e594c5c265f06c600b492372e867a4bb80dc205b545088c39e010d0"}, - {file = "grpcio_tools-1.35.0-cp38-cp38-manylinux2014_i686.whl", hash = "sha256:8bae2611a8e09617922ff4cb11de6fd5f59b91c75a14a318c7d378f427584be1"}, - {file = "grpcio_tools-1.35.0-cp38-cp38-manylinux2014_x86_64.whl", hash = "sha256:0d5028f548fa2b99494baf992dd0e23676361b1a217322be44f6c13b5133f6b3"}, - {file = "grpcio_tools-1.35.0-cp38-cp38-win32.whl", hash = "sha256:8d2c507c093a0ae3df62201ef92ceabcc34ac3f7e53026f12357f8c3641e809a"}, - {file = "grpcio_tools-1.35.0-cp38-cp38-win_amd64.whl", hash = "sha256:994adfe39a1755424e3c33c434786a9fa65090a50515303dfa8125cbec4a5940"}, - {file = "grpcio_tools-1.35.0-cp39-cp39-macosx_10_10_x86_64.whl", hash = "sha256:51bf36ae34f70a8d6ccee5d9d2e52a9e65251670b405f91b7b547a73788f90fb"}, - {file = "grpcio_tools-1.35.0-cp39-cp39-manylinux2010_i686.whl", hash = "sha256:e00dc8d641001409963f78b0b8bf83834eb87c0090357ebc862f874dd0e6dbb5"}, - {file = "grpcio_tools-1.35.0-cp39-cp39-manylinux2010_x86_64.whl", hash = "sha256:5f279dee8b77bf93996592ada3bf56ad44fa9b0e780099172f1a7093a506eb67"}, - {file = "grpcio_tools-1.35.0-cp39-cp39-manylinux2014_i686.whl", hash = "sha256:713b496dd02fc868da0d59cc09536c62452d52035d0b694204d5054e75fe4929"}, - {file = "grpcio_tools-1.35.0-cp39-cp39-manylinux2014_x86_64.whl", hash = "sha256:15fa3c66e6b0ba2e434eccf8cdbce68e4e37b5fe440dbeffb9efd599aa23910f"}, - {file = "grpcio_tools-1.35.0-cp39-cp39-win32.whl", hash = "sha256:ee0f750b5d8d628349e903438bb506196c4c5cee0007e81800d95cd0a2b23e6f"}, - {file = "grpcio_tools-1.35.0-cp39-cp39-win_amd64.whl", hash = "sha256:c8451c60e106310436c123f3243c115db21ccb957402edbe73b1bb68276e4aa4"}, -] -ipython = [ - {file = "ipython-7.20.0-py3-none-any.whl", hash = "sha256:1918dea4bfdc5d1a830fcfce9a710d1d809cbed123e85eab0539259cb0f56640"}, - {file = "ipython-7.20.0.tar.gz", hash = "sha256:1923af00820a8cf58e91d56b89efc59780a6e81363b94464a0f17c039dffff9e"}, -] -ipython-genutils = [ - {file = "ipython_genutils-0.2.0-py2.py3-none-any.whl", hash = "sha256:72dd37233799e619666c9f639a9da83c34013a73e8bbc79a7a6348d93c61fab8"}, - {file = "ipython_genutils-0.2.0.tar.gz", hash = "sha256:eb2e116e75ecef9d4d228fdc66af54269afa26ab4463042e33785b887c628ba8"}, -] -jedi = [ - {file = "jedi-0.18.0-py2.py3-none-any.whl", hash = "sha256:18456d83f65f400ab0c2d3319e48520420ef43b23a086fdc05dff34132f0fb93"}, - {file = "jedi-0.18.0.tar.gz", hash = "sha256:92550a404bad8afed881a137ec9a461fed49eca661414be45059329614ed0707"}, -] -parso = [ - {file = "parso-0.8.1-py2.py3-none-any.whl", hash = "sha256:15b00182f472319383252c18d5913b69269590616c947747bc50bf4ac768f410"}, - {file = "parso-0.8.1.tar.gz", hash = "sha256:8519430ad07087d4c997fda3a7918f7cfa27cb58972a8c89c2a0295a1c940e9e"}, -] -pexpect = [ - {file = "pexpect-4.8.0-py2.py3-none-any.whl", hash = "sha256:0b48a55dcb3c05f3329815901ea4fc1537514d6ba867a152b581d69ae3710937"}, - {file = "pexpect-4.8.0.tar.gz", hash = "sha256:fc65a43959d153d0114afe13997d439c22823a27cefceb5ff35c2178c6784c0c"}, -] -pickleshare = [ - {file = "pickleshare-0.7.5-py2.py3-none-any.whl", hash = "sha256:9649af414d74d4df115d5d718f82acb59c9d418196b7b4290ed47a12ce62df56"}, - {file = "pickleshare-0.7.5.tar.gz", hash = "sha256:87683d47965c1da65cdacaf31c8441d12b8044cdec9aca500cd78fc2c683afca"}, -] -prompt-toolkit = [ - {file = "prompt_toolkit-3.0.16-py3-none-any.whl", hash = "sha256:62c811e46bd09130fb11ab759012a4ae385ce4fb2073442d1898867a824183bd"}, - {file = "prompt_toolkit-3.0.16.tar.gz", hash = "sha256:0fa02fa80363844a4ab4b8d6891f62dd0645ba672723130423ca4037b80c1974"}, -] -protobuf = [ - {file = "protobuf-3.14.0-cp27-cp27m-macosx_10_9_x86_64.whl", hash = "sha256:629b03fd3caae7f815b0c66b41273f6b1900a579e2ccb41ef4493a4f5fb84f3a"}, - {file = "protobuf-3.14.0-cp27-cp27mu-manylinux1_x86_64.whl", hash = "sha256:5b7a637212cc9b2bcf85dd828b1178d19efdf74dbfe1ddf8cd1b8e01fdaaa7f5"}, - {file = "protobuf-3.14.0-cp35-cp35m-macosx_10_9_intel.whl", hash = "sha256:43b554b9e73a07ba84ed6cf25db0ff88b1e06be610b37656e292e3cbb5437472"}, - {file = "protobuf-3.14.0-cp35-cp35m-manylinux1_x86_64.whl", hash = "sha256:5e9806a43232a1fa0c9cf5da8dc06f6910d53e4390be1fa06f06454d888a9142"}, - {file = "protobuf-3.14.0-cp35-cp35m-win32.whl", hash = "sha256:1c51fda1bbc9634246e7be6016d860be01747354ed7015ebe38acf4452f470d2"}, - {file = "protobuf-3.14.0-cp35-cp35m-win_amd64.whl", hash = "sha256:4b74301b30513b1a7494d3055d95c714b560fbb630d8fb9956b6f27992c9f980"}, - {file = "protobuf-3.14.0-cp36-cp36m-macosx_10_9_x86_64.whl", hash = "sha256:86a75477addde4918e9a1904e5c6af8d7b691f2a3f65587d73b16100fbe4c3b2"}, - {file = "protobuf-3.14.0-cp36-cp36m-manylinux1_x86_64.whl", hash = "sha256:ecc33531a213eee22ad60e0e2aaea6c8ba0021f0cce35dbf0ab03dee6e2a23a1"}, - {file = "protobuf-3.14.0-cp36-cp36m-win32.whl", hash = "sha256:72230ed56f026dd664c21d73c5db73ebba50d924d7ba6b7c0d81a121e390406e"}, - {file = "protobuf-3.14.0-cp36-cp36m-win_amd64.whl", hash = "sha256:0fc96785262042e4863b3f3b5c429d4636f10d90061e1840fce1baaf59b1a836"}, - {file = "protobuf-3.14.0-cp37-cp37m-macosx_10_9_x86_64.whl", hash = "sha256:4e75105c9dfe13719b7293f75bd53033108f4ba03d44e71db0ec2a0e8401eafd"}, - {file = "protobuf-3.14.0-cp37-cp37m-manylinux1_x86_64.whl", hash = "sha256:2a7e2fe101a7ace75e9327b9c946d247749e564a267b0515cf41dfe450b69bac"}, - {file = "protobuf-3.14.0-cp37-cp37m-win32.whl", hash = "sha256:b0d5d35faeb07e22a1ddf8dce620860c8fe145426c02d1a0ae2688c6e8ede36d"}, - {file = "protobuf-3.14.0-cp37-cp37m-win_amd64.whl", hash = "sha256:8971c421dbd7aad930c9bd2694122f332350b6ccb5202a8b7b06f3f1a5c41ed5"}, - {file = "protobuf-3.14.0-cp38-cp38-macosx_10_9_x86_64.whl", hash = "sha256:9616f0b65a30851e62f1713336c931fcd32c057202b7ff2cfbfca0fc7d5e3043"}, - {file = "protobuf-3.14.0-cp38-cp38-manylinux1_x86_64.whl", hash = "sha256:22bcd2e284b3b1d969c12e84dc9b9a71701ec82d8ce975fdda19712e1cfd4e00"}, - {file = "protobuf-3.14.0-py2.py3-none-any.whl", hash = "sha256:0e247612fadda953047f53301a7b0407cb0c3cb4ae25a6fde661597a04039b3c"}, - {file = "protobuf-3.14.0.tar.gz", hash = "sha256:1d63eb389347293d8915fb47bee0951c7b5dab522a4a60118b9a18f33e21f8ce"}, -] -ptyprocess = [ - {file = "ptyprocess-0.7.0-py2.py3-none-any.whl", hash = "sha256:4b41f3967fce3af57cc7e94b888626c18bf37a083e3651ca8feeb66d492fef35"}, - {file = "ptyprocess-0.7.0.tar.gz", hash = "sha256:5c5d0a3b48ceee0b48485e0c26037c0acd7d29765ca3fbb5cb3831d347423220"}, -] -pygments = [ - {file = "Pygments-2.7.4-py3-none-any.whl", hash = "sha256:bc9591213a8f0e0ca1a5e68a479b4887fdc3e75d0774e5c71c31920c427de435"}, - {file = "Pygments-2.7.4.tar.gz", hash = "sha256:df49d09b498e83c1a73128295860250b0b7edd4c723a32e9bc0d295c7c2ec337"}, -] -six = [ - {file = "six-1.15.0-py2.py3-none-any.whl", hash = "sha256:8b74bedcbbbaca38ff6d7491d76f2b06b3592611af620f8426e82dddb04a5ced"}, - {file = "six-1.15.0.tar.gz", hash = "sha256:30639c035cdb23534cd4aa2dd52c3bf48f06e5f4a941509c8bafd8ce11080259"}, -] -traitlets = [ - {file = "traitlets-5.0.5-py3-none-any.whl", hash = "sha256:69ff3f9d5351f31a7ad80443c2674b7099df13cc41fc5fa6e2f6d3b0330b0426"}, - {file = "traitlets-5.0.5.tar.gz", hash = "sha256:178f4ce988f69189f7e523337a3e11d91c786ded9360174a3d9ca83e79bc5396"}, -] -wcwidth = [ - {file = "wcwidth-0.2.5-py2.py3-none-any.whl", hash = "sha256:beb4802a9cebb9144e99086eff703a642a13d6a0052920003a230f3294bbe784"}, - {file = "wcwidth-0.2.5.tar.gz", hash = "sha256:c4d647b99872929fdb7bdcaa4fbe7f01413ed3d98077df798530e5b04f116c83"}, -] diff --git a/hack/federation/python-client/pyproject.toml b/hack/federation/python-client/pyproject.toml deleted file mode 100644 index 705b94f1a0e..00000000000 --- a/hack/federation/python-client/pyproject.toml +++ /dev/null @@ -1,16 +0,0 @@ -[tool.poetry] -name = "wire-api-federation" -version = "0.1.0" -description = "" -authors = ["Your Name "] - -[tool.poetry.dependencies] -python = "^3.8" -grpcio-tools = "^1.35.0" -ipython = "^7.20.0" - -[tool.poetry.dev-dependencies] - -[build-system] -requires = ["poetry>=0.12"] -build-backend = "poetry.masonry.api" diff --git a/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs b/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs index 8986d39e897..88deb69274b 100644 --- a/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs +++ b/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs @@ -39,6 +39,7 @@ module Network.Wai.Utilities.Server onError, logError, logError', + logErrorMsg, logIO, runHandlers, restrict, @@ -353,15 +354,16 @@ logError :: (MonadIO m, HasRequest r) => Logger -> Maybe r -> Wai.Error -> m () logError g mr = logError' g (lookupRequestId =<< mr) logError' :: (MonadIO m) => Logger -> Maybe ByteString -> Wai.Error -> m () -logError' g mr (Wai.Error c l m md) = liftIO $ Log.debug g logMsg - where - logMsg = - field "code" (statusCode c) - . field "label" l - . field "request" (fromMaybe "N/A" mr) - . fromMaybe id (fmap logErrorData md) - . msg (val "\"" +++ m +++ val "\"") +logError' g mr e = liftIO $ Log.debug g (logErrorMsg mr e) +logErrorMsg :: Maybe ByteString -> Wai.Error -> Msg -> Msg +logErrorMsg mr (Wai.Error c l m md) = + field "code" (statusCode c) + . field "label" l + . field "request" (fromMaybe "N/A" mr) + . fromMaybe id (fmap logErrorData md) + . msg (val "\"" +++ m +++ val "\"") + where logErrorData (Wai.FederationErrorData d p) = field "domain" (domainText d) . field "path" p diff --git a/libs/wire-api-federation/package.yaml b/libs/wire-api-federation/package.yaml index a2163d0fda4..6b4ff64da17 100644 --- a/libs/wire-api-federation/package.yaml +++ b/libs/wire-api-federation/package.yaml @@ -9,8 +9,6 @@ author: Wire Swiss GmbH maintainer: Wire Swiss GmbH copyright: (c) 2020 Wire Swiss GmbH license: AGPL-3 -extra-source-files: -- proto/router.proto dependencies: - QuickCheck >=2.13 - aeson >=1.4 @@ -19,28 +17,30 @@ dependencies: - bytestring - bytestring-conversion - bytestring +- case-insensitive +- containers - either - errors - exceptions - http-types -- http2-client-grpc +- http2 - imports - lifted-base -- mu-rpc -- mu-grpc-client -- mu-grpc-server -- mu-protobuf -- mu-schema +- metrics-wai - mtl +- network - servant >=0.16 - servant-client - servant-client-core +- servant-server - sop-core +- streaming-commons - template-haskell - text >=0.11 +- time-manager +- tls - time >=1.8 - types-common -- warp - wai-utilities - wire-api library: diff --git a/libs/wire-api-federation/src/Wire/API/Federation/API.hs b/libs/wire-api-federation/src/Wire/API/Federation/API.hs new file mode 100644 index 00000000000..b89d9698eeb --- /dev/null +++ b/libs/wire-api-federation/src/Wire/API/Federation/API.hs @@ -0,0 +1,45 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- 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 . + +module Wire.API.Federation.API + ( FedApi, + clientRoutes, + + -- * Re-exports + Component (..), + ) +where + +import Servant.Client.Generic +import Wire.API.Federation.API.Brig +import Wire.API.Federation.API.Galley +import Wire.API.Federation.Client +import Wire.API.Federation.Component + +class HasFederationAPI (comp :: Component) where + -- Note: this type family being injective means that in most cases there is no need + -- to add component annotations when invoking the federator client + type FedApi comp = (api :: * -> *) | api -> comp + clientRoutes :: FedApi comp (AsClientT (FederatorClient comp)) + +instance HasFederationAPI 'Galley where + type FedApi 'Galley = GalleyApi + clientRoutes = genericClient + +instance HasFederationAPI 'Brig where + type FedApi 'Brig = BrigApi + clientRoutes = genericClient diff --git a/libs/wire-api-federation/src/Wire/API/Federation/API/Brig.hs b/libs/wire-api-federation/src/Wire/API/Federation/API/Brig.hs index ba8bf3f1a9a..38fa01ad792 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/API/Brig.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/API/Brig.hs @@ -17,7 +17,6 @@ module Wire.API.Federation.API.Brig where -import Control.Monad.Except (MonadError (..)) import Data.Aeson import Data.Handle (Handle) import Data.Id @@ -25,13 +24,10 @@ import Data.Range import Imports import Servant.API import Servant.API.Generic -import Servant.Client.Generic (AsClientT, genericClient) import Test.QuickCheck (Arbitrary) import Wire.API.Arbitrary (GenericUniform (..)) import Wire.API.Federation.API.Common -import Wire.API.Federation.Client (FederationClientFailure, FederatorClient) import Wire.API.Federation.Domain (OriginDomainHeader) -import qualified Wire.API.Federation.GRPC.Types as Proto import Wire.API.Message (UserClients) import Wire.API.User (UserProfile) import Wire.API.User.Client (PubClient, UserClientPrekeyMap) @@ -51,63 +47,53 @@ instance FromJSON SearchRequest -- | For conventions see /docs/developer/federation-api-conventions.md -- -- Maybe this module should be called Brig -data Api routes = Api +data BrigApi routes = BrigApi { getUserByHandle :: routes - :- "federation" - :> "get-user-by-handle" + :- "get-user-by-handle" :> ReqBody '[JSON] Handle :> Post '[JSON] (Maybe UserProfile), getUsersByIds :: routes - :- "federation" - :> "get-users-by-ids" + :- "get-users-by-ids" :> ReqBody '[JSON] [UserId] :> Post '[JSON] [UserProfile], claimPrekey :: routes - :- "federation" - :> "claim-prekey" + :- "claim-prekey" :> ReqBody '[JSON] (UserId, ClientId) :> Post '[JSON] (Maybe ClientPrekey), claimPrekeyBundle :: routes - :- "federation" - :> "claim-prekey-bundle" + :- "claim-prekey-bundle" :> ReqBody '[JSON] UserId :> Post '[JSON] PrekeyBundle, claimMultiPrekeyBundle :: routes - :- "federation" - :> "claim-multi-prekey-bundle" + :- "claim-multi-prekey-bundle" :> ReqBody '[JSON] UserClients :> Post '[JSON] UserClientPrekeyMap, searchUsers :: routes - :- "federation" - :> "search-users" + :- "search-users" -- FUTUREWORK(federation): do we want to perform some type-level validation like length checks? -- (handles can be up to 256 chars currently) :> ReqBody '[JSON] SearchRequest :> Post '[JSON] [Contact], getUserClients :: routes - :- "federation" - :> "get-user-clients" + :- "get-user-clients" :> ReqBody '[JSON] GetUserClients :> Post '[JSON] (UserMap (Set PubClient)), sendConnectionAction :: routes - :- "federation" - :> "send-connection-action" + :- "send-connection-action" :> OriginDomainHeader :> ReqBody '[JSON] NewConnectionRequest :> Post '[JSON] NewConnectionResponse, onUserDeleted :: routes - :- "federation" - :> "on-user-deleted" - :> "connections" + :- "on-user-deleted-connections" :> OriginDomainHeader :> ReqBody '[JSON] UserDeletedConnectionsNotification :> Post '[JSON] EmptyResponse @@ -172,6 +158,3 @@ data UserDeletedConnectionsNotification = UserDeletedConnectionsNotification deriving stock (Eq, Show, Generic) deriving (Arbitrary) via (GenericUniform UserDeletedConnectionsNotification) deriving (FromJSON, ToJSON) via (CustomEncoded UserDeletedConnectionsNotification) - -clientRoutes :: (MonadError FederationClientFailure m, MonadIO m) => Api (AsClientT (FederatorClient 'Proto.Brig m)) -clientRoutes = genericClient diff --git a/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs b/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs index 47a7b928dee..d2d74e5e9d4 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs @@ -17,7 +17,6 @@ module Wire.API.Federation.API.Galley where -import Control.Monad.Except (MonadError (..)) import Data.Aeson (FromJSON, ToJSON) import Data.Id (ClientId, ConvId, UserId) import Data.Json.Util (Base64ByteString) @@ -27,8 +26,7 @@ import Data.Range import Data.Time.Clock (UTCTime) import Imports import Servant.API (JSON, Post, ReqBody, Summary, (:>)) -import Servant.API.Generic ((:-)) -import Servant.Client.Generic (AsClientT, genericClient) +import Servant.API.Generic import Wire.API.Arbitrary (Arbitrary, GenericUniform (..)) import Wire.API.Conversation ( Access, @@ -41,9 +39,7 @@ import Wire.API.Conversation.Action import Wire.API.Conversation.Member (OtherMember) import Wire.API.Conversation.Role (RoleName) import Wire.API.Federation.API.Common -import Wire.API.Federation.Client (FederationClientFailure, FederatorClient) import Wire.API.Federation.Domain (OriginDomainHeader) -import qualified Wire.API.Federation.GRPC.Types as Proto import Wire.API.Message (MessageNotSent, MessageSendingStatus, PostOtrResponse, Priority) import Wire.API.User.Client (UserClientMap) import Wire.API.Util.Aeson (CustomEncoded (..)) @@ -53,20 +49,18 @@ import Wire.API.Util.Aeson (CustomEncoded (..)) -- for the current list we need. -- | For conventions see /docs/developer/federation-api-conventions.md -data Api routes = Api +data GalleyApi routes = GalleyApi { -- | Register a new conversation onConversationCreated :: routes - :- "federation" - :> Summary "Register users to be in a new remote conversation" + :- Summary "Register users to be in a new remote conversation" :> "on-conversation-created" :> OriginDomainHeader :> ReqBody '[JSON] (NewRemoteConversation ConvId) :> Post '[JSON] (), getConversations :: routes - :- "federation" - :> "get-conversations" + :- "get-conversations" :> OriginDomainHeader :> ReqBody '[JSON] GetConversationsRequest :> Post '[JSON] GetConversationsResponse, @@ -74,15 +68,13 @@ data Api routes = Api -- changes to the conversation onConversationUpdated :: routes - :- "federation" - :> "on-conversation-updated" + :- "on-conversation-updated" :> OriginDomainHeader :> ReqBody '[JSON] ConversationUpdate :> Post '[JSON] (), leaveConversation :: routes - :- "federation" - :> "leave-conversation" + :- "leave-conversation" :> OriginDomainHeader :> ReqBody '[JSON] LeaveConversationRequest :> Post '[JSON] LeaveConversationResponse, @@ -90,8 +82,7 @@ data Api routes = Api -- remote conversation onMessageSent :: routes - :- "federation" - :> "on-message-sent" + :- "on-message-sent" :> OriginDomainHeader :> ReqBody '[JSON] (RemoteMessage ConvId) :> Post '[JSON] (), @@ -99,16 +90,13 @@ data Api routes = Api -- this backend sendMessage :: routes - :- "federation" - :> "send-message" + :- "send-message" :> OriginDomainHeader :> ReqBody '[JSON] MessageSendRequest :> Post '[JSON] MessageSendResponse, onUserDeleted :: routes - :- "federation" - :> "on-user-deleted" - :> "conversations" + :- "on-user-deleted-conversations" :> OriginDomainHeader :> ReqBody '[JSON] UserDeletedConversationsNotification :> Post '[JSON] EmptyResponse @@ -276,13 +264,10 @@ type UserDeletedNotificationMaxConvs = 1000 data UserDeletedConversationsNotification = UserDeletedConversationsNotification { -- | This is qualified implicitly by the origin domain - udcnUser :: UserId, + udcvUser :: UserId, -- | These are qualified implicitly by the target domain - udcnConversations :: Range 1 UserDeletedNotificationMaxConvs [ConvId] + udcvConversations :: Range 1 UserDeletedNotificationMaxConvs [ConvId] } deriving stock (Eq, Show, Generic) deriving (Arbitrary) via (GenericUniform UserDeletedConversationsNotification) deriving (FromJSON, ToJSON) via (CustomEncoded UserDeletedConversationsNotification) - -clientRoutes :: (MonadError FederationClientFailure m, MonadIO m) => Api (AsClientT (FederatorClient 'Proto.Galley m)) -clientRoutes = genericClient diff --git a/libs/wire-api-federation/src/Wire/API/Federation/Client.hs b/libs/wire-api-federation/src/Wire/API/Federation/Client.hs index cb2cfc2522f..4215def0283 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/Client.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/Client.hs @@ -18,166 +18,235 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Wire.API.Federation.Client where - +module Wire.API.Federation.Client + ( FederatorClientEnv (..), + FederatorClient, + runFederatorClient, + performHTTP2Request, + headersFromTable, + ) +where + +import qualified Control.Exception as E import Control.Monad.Catch -import Control.Monad.Except (ExceptT, MonadError (..), withExceptT) -import Control.Monad.State (MonadState (..), StateT, evalStateT, gets) -import Data.ByteString.Builder (toLazyByteString) +import Control.Monad.Except +import qualified Data.Aeson as Aeson +import qualified Data.ByteString as BS +import Data.ByteString.Builder +import Data.ByteString.Conversion (toByteString') import qualified Data.ByteString.Lazy as LBS -import Data.Domain (Domain, domainText) -import qualified Data.Text as T +import Data.Domain +import qualified Data.Sequence as Seq +import Data.Streaming.Network +import qualified Data.Text.Encoding as Text +import qualified Data.Text.Encoding.Error as Text +import qualified Data.Text.Lazy.Encoding as LText +import Foreign.Marshal.Alloc import Imports -import Mu.GRpc.Client.TyApps +import qualified Network.HPACK as HTTP2 +import qualified Network.HPACK.Token as HTTP2 import qualified Network.HTTP.Types as HTTP -import Servant.Client (ResponseF (..)) -import qualified Servant.Client as Servant -import Servant.Client.Core (RequestBody (..), RequestF (..), RunClient (..)) +import qualified Network.HTTP2.Client as HTTP2 +import qualified Network.Socket as NS +import Network.TLS as TLS +import qualified Network.Wai.Utilities.Error as Wai +import Servant.Client +import Servant.Client.Core +import qualified System.TimeManager import Util.Options (Endpoint (..)) -import Wire.API.Federation.GRPC.Client -import qualified Wire.API.Federation.GRPC.Types as Proto +import Wire.API.Federation.Component +import Wire.API.Federation.Domain (originDomainHeaderName) +import Wire.API.Federation.Error --- FUTUREWORK: Remove originDomain from here and make it part of all the API --- calls or figure out some smarter way of making API calls so it doesn't have --- to be specified everywhere. data FederatorClientEnv = FederatorClientEnv - { grpcClient :: GrpcClient, - targetDomain :: Domain, - originDomain :: Domain + { ceOriginDomain :: Domain, + ceTargetDomain :: Domain, + ceFederator :: Endpoint } --- the state monad is used to store the request path in case of servant errors -newtype FederatorClient (component :: Proto.Component) m a = FederatorClient {runFederatorClient :: ReaderT FederatorClientEnv (StateT (Maybe ByteString) m) a} - deriving newtype (Functor, Applicative, Monad, MonadReader FederatorClientEnv, MonadState (Maybe ByteString), MonadIO) - -runFederatorClientWith :: Monad m => GrpcClient -> Domain -> Domain -> FederatorClient component m a -> m a -runFederatorClientWith client targetDomain originDomain = - flip evalStateT Nothing - . flip runReaderT (FederatorClientEnv client targetDomain originDomain) - . runFederatorClient - -class KnownComponent (c :: Proto.Component) where - componentVal :: Proto.Component - -instance KnownComponent 'Proto.Brig where - componentVal = Proto.Brig - -instance KnownComponent 'Proto.Galley where - componentVal = Proto.Galley - --- | expectedStatuses is ignored as we don't get any status from the federator, --- all responses have '200 OK' as their status. -instance (Monad m, MonadIO m, MonadError FederationClientFailure m, KnownComponent component) => RunClient (FederatorClient component m) where - runRequestAcceptStatus _expectedStatuses req = do +newtype FederatorClient (c :: Component) a = FederatorClient + {unFederatorClient :: ReaderT FederatorClientEnv (ExceptT FederatorClientError IO) a} + deriving newtype + ( Functor, + Applicative, + Monad, + MonadReader FederatorClientEnv, + MonadError FederatorClientError, + MonadIO + ) + +headersFromTable :: HTTP2.HeaderTable -> [HTTP.Header] +headersFromTable (headerList, _) = flip map headerList $ \(token, headerValue) -> + (HTTP2.tokenKey token, headerValue) + +connectSocket :: ByteString -> Int -> IO NS.Socket +connectSocket hostname port = + handle (E.throw . FederatorClientConnectionError) + . fmap fst + $ getSocketFamilyTCP hostname port NS.AF_UNSPEC + +performHTTP2Request :: + Maybe TLS.ClientParams -> + HTTP2.Request -> + ByteString -> + Int -> + IO (Either FederatorClientHTTP2Error (HTTP.Status, [HTTP.Header], Builder)) +performHTTP2Request mtlsConfig req hostname port = do + let drainResponse resp = go mempty + where + go acc = do + chunk <- HTTP2.getResponseBodyChunk resp + if BS.null chunk + then pure acc + else go (acc <> byteString chunk) + let clientConfig = + HTTP2.ClientConfig + "https" + hostname + {- cacheLimit: -} 20 + flip + E.catches + [ -- catch FederatorClientHTTP2Error (e.g. connection and TLS errors) + E.Handler (pure . Left), + -- catch HTTP2 exceptions + E.Handler (pure . Left . FederatorClientHTTP2Exception) + ] + $ bracket (connectSocket hostname port) NS.close $ \sock -> do + let withHTTP2Config k = case mtlsConfig of + Nothing -> bracket (HTTP2.allocSimpleConfig sock 4096) HTTP2.freeSimpleConfig k + -- FUTUREWORK(federation): Use openssl + Just tlsConfig -> do + ctx <- E.handle (E.throw . FederatorClientTLSException) $ do + ctx <- TLS.contextNew sock tlsConfig + TLS.handshake ctx + pure ctx + bracket (allocTLSConfig ctx 4096) freeTLSConfig k + withHTTP2Config $ \conf -> + HTTP2.run clientConfig conf $ \sendRequest -> do + sendRequest req $ \resp -> do + result <- drainResponse resp + let headers = headersFromTable (HTTP2.responseHeaders resp) + pure $ case HTTP2.responseStatus resp of + Nothing -> Left FederatorClientNoStatusCode + Just status -> Right (status, headers, result) + +instance KnownComponent c => RunClient (FederatorClient c) where + runRequestAcceptStatus expectedStatuses req = do env <- ask - let path = LBS.toStrict . toLazyByteString $ requestPath req - domain = targetDomain env - mkFailure = FederationClientFailure domain path - failure :: MonadError FederationClientFailure n => FederationClientError -> n x - failure = throwError . mkFailure - rpcFailure = failure . FederationClientRPCError - readBody = \case - RequestBodyLBS lbs -> pure $ LBS.toStrict lbs - RequestBodyBS bs -> pure bs - RequestBodySource _ -> failure FederationClientStreamingUnsupported - -- save path in the state, so that we can access it from throwClientError - -- if necessary - put (Just path) - body <- readBody . maybe (RequestBodyBS "") fst $ requestBody req - let call = - Proto.ValidatedFederatedRequest - domain - ( Proto.Request - (componentVal @component) - path - body - (domainText (originDomain env)) - ) - grpcResponse <- callRemote (grpcClient env) call - case grpcResponse of - GRpcTooMuchConcurrency _tmc -> rpcFailure "too much concurrency" - GRpcErrorCode code -> rpcFailure $ "grpc error code: " <> T.pack (show code) - GRpcErrorString msg -> rpcFailure $ "grpc error: " <> T.pack msg - GRpcClientError msg -> rpcFailure $ "grpc client error: " <> T.pack (show msg) - GRpcOk (Proto.OutwardResponseError err) -> failure (FederationClientOutwardError err) - GRpcOk (Proto.OutwardResponseInwardError err) -> failure (FederationClientInwardError err) - GRpcOk (Proto.OutwardResponseBody res) -> do - pure $ - Response - { responseStatusCode = HTTP.ok200, - -- This is required so servant can parse the body - responseHeaders = [(HTTP.hContentType, "application/json")], - -- Here HTTP 1.1 is hardcoded with the hope that it wouldn't - -- really be used anywhere. - responseHttpVersion = HTTP.http11, - responseBody = LBS.fromStrict res - } - - throwClientError err = do - dom <- asks targetDomain - path <- gets (fromMaybe "") - throwError (FederationClientFailure dom path (FederationClientServantError err)) - -instance (Monad m, MonadError FederationClientFailure m) => MonadError FederationClientFailure (FederatorClient c m) where - throwError = FederatorClient . throwError - catchError (FederatorClient action) f = FederatorClient $ catchError action (runFederatorClient . f) - -data FederationError - = FederationUnavailable Text - | FederationNotImplemented - | FederationNotConfigured - | FederationCallFailure FederationClientFailure - | FederationUnexpectedBody Text - deriving (Show, Eq, Typeable) - -instance Exception FederationError - -data FederationClientFailure = FederationClientFailure - { fedFailDomain :: Domain, - fedFailPath :: ByteString, - fedFailError :: FederationClientError - } - deriving (Show, Eq, Typeable) - -data FederationClientError - = FederationClientInvalidMethod HTTP.Method - | FederationClientStreamingUnsupported - | FederationClientRPCError Text - | FederationClientOutwardError Proto.OutwardError - | FederationClientInwardError Proto.InwardError - | FederationClientServantError Servant.ClientError - deriving (Show, Eq, Typeable) - -callRemote :: MonadIO m => GrpcClient -> Proto.ValidatedFederatedRequest -> m (GRpcReply Proto.OutwardResponse) -callRemote fedClient call = liftIO $ gRpcCall @'MsgProtoBuf @Proto.Outward @"Outward" @"call" fedClient (Proto.validatedFederatedRequestToFederatedRequest call) - -class HasFederatorConfig m where - federatorEndpoint :: m (Maybe Endpoint) - federationDomain :: m Domain - --- FUTUREWORK: It would be nice to share the client across all calls to --- federator and not call this function on every invocation of federated --- requests, but there are some issues in http2-client which might need some --- fixing first. More context here: --- https://github.com/lucasdicioccio/http2-client/issues/37 --- https://github.com/lucasdicioccio/http2-client/issues/49 -mkFederatorClient :: - (MonadIO m, HasFederatorConfig m) => - ExceptT FederationError m GrpcClient -mkFederatorClient = do - mbFedEndpoint <- lift federatorEndpoint - Endpoint host port <- maybe (throwError FederationNotConfigured) pure mbFedEndpoint - let cfg = grpcClientConfigSimple (T.unpack host) (fromIntegral port) False - createGrpcClient cfg - >>= either (throwError . FederationUnavailable . reason) pure - -executeFederated :: - (MonadIO m, MonadMask m, HasFederatorConfig m) => - Domain -> - FederatorClient component (ExceptT FederationClientFailure m) a -> - ExceptT FederationError m a -executeFederated targetDomain action = do - originDomain <- lift federationDomain - bracket mkFederatorClient closeGrpcClient $ \federatorClient -> - withExceptT FederationCallFailure $ - runFederatorClientWith federatorClient targetDomain originDomain action + let baseUrlPath = + HTTP.encodePathSegments + [ "rpc", + domainText (ceTargetDomain env), + componentName (componentVal @c) + ] + let path = baseUrlPath <> requestPath req + body <- case requestBody req of + Just (RequestBodyLBS lbs, _) -> pure lbs + Just (RequestBodyBS bs, _) -> pure (LBS.fromStrict bs) + Just (RequestBodySource _, _) -> + throwError FederatorClientStreamingNotSupported + Nothing -> pure mempty + let req' = + HTTP2.requestBuilder + (requestMethod req) + (LBS.toStrict (toLazyByteString path)) + (toList (requestHeaders req) <> [(originDomainHeaderName, toByteString' (ceOriginDomain env))]) + (lazyByteString body) + let Endpoint (Text.encodeUtf8 -> hostname) (fromIntegral -> port) = ceFederator env + eresp <- liftIO $ performHTTP2Request Nothing req' hostname port + case eresp of + Left err -> throwError (FederatorClientHTTP2Error err) + Right (status, headers, result) + | maybe (HTTP.statusIsSuccessful status) (elem status) expectedStatuses -> + pure $ + Response + { responseStatusCode = status, + responseHeaders = Seq.fromList headers, + responseHttpVersion = HTTP.http20, + responseBody = toLazyByteString result + } + | otherwise -> + throwError $ + FederatorClientError + ( mkFailureResponse + status + (ceTargetDomain env) + (toLazyByteString (requestPath req)) + (toLazyByteString result) + ) + + throwClientError = throwError . FederatorClientServantError + +mkFailureResponse :: HTTP.Status -> Domain -> LByteString -> LByteString -> Wai.Error +mkFailureResponse status domain path body + -- If the outward federator fails with 403, that means that there was an + -- error at the level of the local federator (most likely due to a bug somewhere + -- in wire-server). It does not make sense to return this error directly to the + -- client, since it is always due to a server issue, so we map it to a 500 + -- error. + | HTTP.statusCode status == 403 = + Wai.mkError + HTTP.status500 + "federation-local-error" + ( "Local federator failure: " + <> LText.decodeUtf8With Text.lenientDecode body + ) + -- Any other error is interpreted as a correctly formatted wai error, and + -- returned to the client. + | otherwise = + (fromMaybe defaultError (Aeson.decode body)) + { Wai.errorData = + Just + Wai.FederationErrorData + { Wai.federrDomain = domain, + Wai.federrPath = + "/federation" + <> Text.decodeUtf8With Text.lenientDecode (LBS.toStrict path) + } + } + where + defaultError = + Wai.mkError + status + "unknown-federation-error" + (LText.decodeUtf8With Text.lenientDecode body) + +runFederatorClient :: + KnownComponent c => + FederatorClientEnv -> + FederatorClient c a -> + IO (Either FederatorClientError a) +runFederatorClient env action = runExceptT (runReaderT (unFederatorClient action) env) + +freeTLSConfig :: HTTP2.Config -> IO () +freeTLSConfig cfg = free (HTTP2.confWriteBuffer cfg) + +allocTLSConfig :: TLS.Context -> HTTP2.BufferSize -> IO HTTP2.Config +allocTLSConfig ctx bufsize = do + buf <- mallocBytes bufsize + timmgr <- System.TimeManager.initialize $ 30 * 1000000 + ref <- newIORef mempty + let readData :: Int -> IO ByteString + readData n = do + chunk <- readIORef ref + if BS.length chunk >= n + then case BS.splitAt n chunk of + (result, chunk') -> do + writeIORef ref chunk' + pure result + else do + chunk' <- TLS.recvData ctx + if BS.null chunk' + then pure chunk + else do + modifyIORef ref (<> chunk') + readData n + pure + HTTP2.Config + { HTTP2.confWriteBuffer = buf, + HTTP2.confBufferSize = bufsize, + HTTP2.confSendAll = TLS.sendData ctx . LBS.fromStrict, + HTTP2.confReadN = readData, + HTTP2.confPositionReadMaker = HTTP2.defaultPositionReadMaker, + HTTP2.confTimeoutManager = timmgr + } diff --git a/libs/wire-api-federation/src/Wire/API/Federation/GRPC/Helper.hs b/libs/wire-api-federation/src/Wire/API/Federation/Component.hs similarity index 54% rename from libs/wire-api-federation/src/Wire/API/Federation/GRPC/Helper.hs rename to libs/wire-api-federation/src/Wire/API/Federation/Component.hs index 552e351c9b1..f2c997ee25b 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/GRPC/Helper.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/Component.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TemplateHaskell #-} - -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2020 Wire Swiss GmbH @@ -18,23 +15,32 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Wire.API.Federation.GRPC.Helper where +module Wire.API.Federation.Component where import Imports -import Language.Haskell.TH.Syntax (Dec, Q, addDependentFile) - -routerProtoFile :: FilePath -#if __GHCIDE__ -routerProtoFile = "libs/wire-api-federation/proto/router.proto" -#elif WIRE_GHCI --- Similar to __GHCIDE__ this fixes a compilation issue with ghci and ghcid. --- There doesn't seem to be cpp variable to signify GHCI, so use -DWIRE_GHCI -routerProtoFile = "libs/wire-api-federation/proto/router.proto" -#else -routerProtoFile = "proto/router.proto" -#endif - -recompileRouterUponProtoChanges :: Q [Dec] -recompileRouterUponProtoChanges = do - addDependentFile routerProtoFile - pure [] +import Test.QuickCheck (Arbitrary) +import Wire.API.Arbitrary (GenericUniform (..)) + +data Component + = Brig + | Galley + deriving (Show, Eq, Generic) + deriving (Arbitrary) via (GenericUniform Component) + +parseComponent :: Text -> Maybe Component +parseComponent "brig" = Just Brig +parseComponent "galley" = Just Galley +parseComponent _ = Nothing + +componentName :: Component -> Text +componentName Brig = "brig" +componentName Galley = "galley" + +class KnownComponent (c :: Component) where + componentVal :: Component + +instance KnownComponent 'Brig where + componentVal = Brig + +instance KnownComponent 'Galley where + componentVal = Galley diff --git a/libs/wire-api-federation/src/Wire/API/Federation/Domain.hs b/libs/wire-api-federation/src/Wire/API/Federation/Domain.hs index f19e9ceef8c..ce7038be62e 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/Domain.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/Domain.hs @@ -18,14 +18,38 @@ module Wire.API.Federation.Domain where import Data.Domain (Domain) +import Data.Metrics.Servant import Data.Proxy (Proxy (..)) import GHC.TypeLits (Symbol, symbolVal) import Imports -import Servant.API (Header', Required, Strict) +import Servant.API (Header', Required, Strict, (:>)) +import Servant.Client +import Servant.Server +import Servant.Server.Internal (MkContextWithErrorFormatter) type OriginDomainHeaderName = "Wire-Origin-Domain" :: Symbol -type OriginDomainHeader = Header' [Strict, Required] OriginDomainHeaderName Domain +data OriginDomainHeader + +instance RoutesToPaths api => RoutesToPaths (OriginDomainHeader :> api) where + getRoutes = getRoutes @api + +instance HasClient m api => HasClient m (OriginDomainHeader :> api) where + type Client m (OriginDomainHeader :> api) = Client m api + clientWithRoute pm _ req = clientWithRoute pm (Proxy @api) req + hoistClientMonad pm _ = hoistClientMonad pm (Proxy @api) + +type OriginDomainHeaderHasServer = Header' [Strict, Required] OriginDomainHeaderName Domain + +instance + ( HasServer api context, + HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters + ) => + HasServer (OriginDomainHeader :> api) context + where + type ServerT (OriginDomainHeader :> api) m = Domain -> ServerT api m + route _pa = route (Proxy @(OriginDomainHeaderHasServer :> api)) + hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s originDomainHeaderName :: IsString a => a originDomainHeaderName = fromString $ symbolVal (Proxy @OriginDomainHeaderName) diff --git a/libs/wire-api-federation/src/Wire/API/Federation/Error.hs b/libs/wire-api-federation/src/Wire/API/Federation/Error.hs index 8b363936164..ffe9896207c 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/Error.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/Error.hs @@ -15,7 +15,17 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Wire.API.Federation.Error where +module Wire.API.Federation.Error + ( FederatorClientHTTP2Error (..), + FederatorClientError (..), + FederationError (..), + federationErrorToWai, + federationRemoteHTTP2Error, + federationRemoteResponseError, + federationNotImplemented, + federationNotConfigured, + ) +where import qualified Data.Text as T import qualified Data.Text.Encoding as T @@ -23,61 +33,167 @@ import qualified Data.Text.Lazy as LT import Imports import Network.HTTP.Types.Status import qualified Network.HTTP.Types.Status as HTTP +import qualified Network.HTTP2.Frame as HTTP2 +import Network.TLS import qualified Network.Wai.Utilities.Error as Wai -import qualified Servant.Client as Servant -import Wire.API.Federation.Client - ( FederationClientError (..), - FederationClientFailure (..), - FederationError (..), - ) -import qualified Wire.API.Federation.GRPC.Types as Proto +import Servant.Client + +-- | Transport-layer errors in federator client. +data FederatorClientHTTP2Error + = FederatorClientNoStatusCode + | FederatorClientHTTP2Exception HTTP2.HTTP2Error + | FederatorClientTLSException TLSException + | FederatorClientConnectionError IOException + deriving (Show, Typeable) + +instance Exception FederatorClientHTTP2Error + +-- | Possible errors resulting from a use of the federator client. +data FederatorClientError + = -- | An error that occurred when establishing a connection to or + -- communicating with the local federator. + FederatorClientHTTP2Error FederatorClientHTTP2Error + | -- | Federator client does not currently support streaming, so this error + -- will be thrown when using federator client to call APIs that contain a + -- streaming body. + FederatorClientStreamingNotSupported + | -- | This error will be thrown when the response received from federator + -- cannot be parsed by the servant machinery (e.g. its content type is + -- malformed or unsupported). + FederatorClientServantError ClientError + | -- | This error will be thrown when federator returns an error response. + FederatorClientError Wai.Error + deriving (Show, Typeable) + +instance Exception FederatorClientError + +-- | High level federation errors. When something goes wrong during a federated +-- call, this error type should be used to represent the failure that occurred. +-- +-- Note that federator client itself can only throw errors of type +-- 'FederatorClientError', corresponding to the 'FederationCallFailure' +-- constructor of 'FederationError'. +data FederationError + = -- | To be used by endpoints to signal federation code paths that haven't + -- been fully implemented yet. + FederationNotImplemented + | -- | No federator endpoint has been set, so no call to federator client can + -- be made. + FederationNotConfigured + | -- | An error occurred while invoking federator client (see + -- 'FederatorClientError' for more details). + FederationCallFailure FederatorClientError + | -- | Federator client was invoked successfully, but the returned value is + -- incorrect. For example, if a single conversation was requested from the + -- remote backend, but multiple conversations have been returned. This can + -- indicate a bug in either backend, or an incompatibility in the + -- server-to-server API. + FederationUnexpectedBody Text + deriving (Show, Typeable) + +instance Exception FederationError federationErrorToWai :: FederationError -> Wai.Error -federationErrorToWai (FederationUnavailable err) = federationUnavailable err federationErrorToWai FederationNotImplemented = federationNotImplemented federationErrorToWai FederationNotConfigured = federationNotConfigured -federationErrorToWai (FederationCallFailure failure) = addErrorData $ - case fedFailError failure of - FederationClientRPCError msg -> - Wai.mkError - HTTP.status500 - "client-rpc-error" - (LT.fromStrict msg) - FederationClientInvalidMethod mth -> - federationInvalidCall - ("Unexpected method: " <> LT.fromStrict (T.decodeUtf8 mth)) - FederationClientStreamingUnsupported -> federationInvalidCall "Streaming unsupported" - FederationClientOutwardError outwardErr -> federationRemoteError outwardErr - FederationClientInwardError inwardErr -> federationRemoteInwardError inwardErr - FederationClientServantError (Servant.DecodeFailure msg _) -> federationInvalidBody msg - FederationClientServantError (Servant.FailureResponse _ _) -> - Wai.mkError unexpectedFederationResponseStatus "unknown-federation-error" "Unknown federation error" - FederationClientServantError (Servant.InvalidContentTypeHeader res) -> - Wai.mkError - unexpectedFederationResponseStatus - "federation-invalid-content-type-header" - ("Content-type: " <> contentType res) - FederationClientServantError (Servant.UnsupportedContentType mediaType res) -> - Wai.mkError - unexpectedFederationResponseStatus - "federation-unsupported-content-type" - ("Content-type: " <> contentType res <> ", Media-Type: " <> LT.pack (show mediaType)) - FederationClientServantError (Servant.ConnectionError exception) -> - federationUnavailable . T.pack . show $ exception - where - contentType = LT.fromStrict . T.decodeUtf8 . maybe "" snd . find (\(name, _) -> name == "Content-Type") . Servant.responseHeaders - addErrorData :: Wai.Error -> Wai.Error - addErrorData err = - err - { Wai.errorData = - Just - Wai.FederationErrorData - { Wai.federrDomain = fedFailDomain failure, - Wai.federrPath = T.decodeUtf8 (fedFailPath failure) - } - } +federationErrorToWai (FederationCallFailure err) = federationClientErrorToWai err federationErrorToWai (FederationUnexpectedBody s) = federationUnexpectedBody s +federationClientErrorToWai :: FederatorClientError -> Wai.Error +federationClientErrorToWai (FederatorClientHTTP2Error e) = + federationClientHTTP2Error e +federationClientErrorToWai FederatorClientStreamingNotSupported = + Wai.mkError HTTP.status500 "internal-error" "Federated streaming not implemented" +federationClientErrorToWai (FederatorClientServantError err) = + federationServantErrorToWai err +federationClientErrorToWai (FederatorClientError err) = err + +federationRemoteHTTP2Error :: FederatorClientHTTP2Error -> Wai.Error +federationRemoteHTTP2Error FederatorClientNoStatusCode = + Wai.mkError + unexpectedFederationResponseStatus + "federation-http2-error" + "No status code in HTTP2 response" +federationRemoteHTTP2Error (FederatorClientHTTP2Exception e) = + Wai.mkError + unexpectedFederationResponseStatus + "federation-http2-error" + (LT.pack (displayException e)) +federationRemoteHTTP2Error (FederatorClientTLSException e) = + Wai.mkError + (HTTP.mkStatus 525 "SSL Handshake Failure") + "tls-failure" + (LT.fromStrict (displayTLSException e)) +federationRemoteHTTP2Error (FederatorClientConnectionError e) = + Wai.mkError + federatorConnectionRefusedStatus + "federation-connection-refused" + (LT.pack (displayException e)) + +federationClientHTTP2Error :: FederatorClientHTTP2Error -> Wai.Error +federationClientHTTP2Error (FederatorClientConnectionError e) = + Wai.mkError + HTTP.status500 + "federation-not-available" + (LT.pack (displayException e)) +federationClientHTTP2Error e = + Wai.mkError + HTTP.status500 + "federator-client-error" + (LT.pack (displayException e)) + +federationRemoteResponseError :: HTTP.Status -> Wai.Error +federationRemoteResponseError status = + Wai.mkError + unexpectedFederationResponseStatus + "federation-remote-error" + ( "A remote federator failed with status code " + <> LT.pack (show (HTTP.statusCode status)) + ) + +displayTLSException :: TLSException -> Text +displayTLSException (Terminated _ reason err) = T.pack reason <> ": " <> displayTLSError err +displayTLSException (HandshakeFailed err) = T.pack "handshake failed: " <> displayTLSError err +displayTLSException ConnectionNotEstablished = T.pack "connection not established" + +displayTLSError :: TLSError -> Text +displayTLSError (Error_Misc msg) = T.pack msg +displayTLSError (Error_Protocol (msg, _, _)) = "protocol error: " <> T.pack msg +displayTLSError (Error_Certificate msg) = "certificate error: " <> T.pack msg +displayTLSError (Error_HandshakePolicy msg) = "handshake policy error: " <> T.pack msg +displayTLSError Error_EOF = "end-of-file error" +displayTLSError (Error_Packet msg) = "packet error: " <> T.pack msg +displayTLSError (Error_Packet_unexpected actual expected) = + "unexpected packet: " <> T.pack expected <> ", " <> "got " <> T.pack actual +displayTLSError (Error_Packet_Parsing msg) = "packet parsing error: " <> T.pack msg + +federationServantErrorToWai :: ClientError -> Wai.Error +federationServantErrorToWai (DecodeFailure msg _) = federationInvalidBody msg +federationServantErrorToWai (FailureResponse _ _) = federationUnknownError +federationServantErrorToWai (InvalidContentTypeHeader res) = + Wai.mkError + unexpectedFederationResponseStatus + "federation-invalid-content-type-header" + ("Content-type: " <> federationErrorContentType res) +federationServantErrorToWai (UnsupportedContentType mediaType res) = + Wai.mkError + unexpectedFederationResponseStatus + "federation-unsupported-content-type" + ( "Content-type: " <> federationErrorContentType res + <> ", Media-Type: " + <> LT.pack (show mediaType) + ) +federationServantErrorToWai (ConnectionError e) = + federationUnavailable . T.pack . displayException $ e + +federationErrorContentType :: ResponseF a -> LT.Text +federationErrorContentType = + LT.fromStrict + . T.decodeUtf8 + . maybe "" snd + . find (\(name, _) -> name == "Content-Type") + . responseHeaders + noFederationStatus :: Status noFederationStatus = status403 @@ -94,13 +210,6 @@ federationNotImplemented = "federation-not-implemented" "Federation is not yet implemented for this endpoint" -federationInvalidCode :: Word32 -> Wai.Error -federationInvalidCode code = - Wai.mkError - unexpectedFederationResponseStatus - "federation-invalid-code" - ("Invalid response code from remote federator: " <> LT.pack (show code)) - federationInvalidBody :: Text -> Wai.Error federationInvalidBody msg = Wai.mkError @@ -129,38 +238,9 @@ federationUnavailable err = "federation-not-available" ("Local federator not available: " <> LT.fromStrict err) -federationRemoteInwardError :: Proto.InwardError -> Wai.Error -federationRemoteInwardError err = Wai.mkError status (LT.fromStrict label) (LT.fromStrict msg) - where - msg = Proto.inwardErrorMsg err - (status, label) = case Proto.inwardErrorType err of - Proto.IInvalidEndpoint -> (HTTP.Status 531 "Version Mismatch", "inward-invalid-endpoint") - Proto.IFederationDeniedByRemote -> (HTTP.Status 532 "Federation Denied", "federation-denied-by-remote") - Proto.IAuthenticationFailed -> (unexpectedFederationResponseStatus, "server-to-server-authentication-failed") - Proto.IForbiddenEndpoint -> (unexpectedFederationResponseStatus, "forbidden-endpoint") - Proto.IDiscoveryFailed -> (HTTP.status500, "remote-discovery-failure") - Proto.IOther -> (unexpectedFederationResponseStatus, "inward-other") - -federationRemoteError :: Proto.OutwardError -> Wai.Error -federationRemoteError err = case Proto.outwardErrorType err of - Proto.RemoteNotFound -> mkErr HTTP.status422 "srv-record-not-found" - Proto.DiscoveryFailed -> mkErr HTTP.status500 "srv-lookup-dns-error" - Proto.ConnectionRefused -> - mkErr - (HTTP.Status 521 "Web Server Is Down") - "cannot-connect-to-remote-federator" - Proto.TLSFailure -> mkErr (HTTP.Status 525 "SSL Handshake Failure") "tls-failure" - Proto.VersionMismatch -> mkErr (HTTP.Status 531 "Version Mismatch") "version-mismatch" - Proto.FederationDeniedByRemote -> - mkErr - (HTTP.Status 532 "Federation Denied") - "federation-denied-remotely" - Proto.FederationDeniedLocally -> mkErr HTTP.status400 "federation-not-allowed" - Proto.TooMuchConcurrency -> mkErr unexpectedFederationResponseStatus "too-much-concurrency" - Proto.GrpcError -> mkErr unexpectedFederationResponseStatus "grpc-error" - Proto.InvalidRequest -> mkErr HTTP.status500 "invalid-request-to-federator" - where - mkErr status label = Wai.mkError status label (LT.fromStrict (Proto.outwardErrorMessage err)) - -federationInvalidCall :: LText -> Wai.Error -federationInvalidCall = Wai.mkError HTTP.status500 "federation-invalid-call" +federationUnknownError :: Wai.Error +federationUnknownError = + Wai.mkError + unexpectedFederationResponseStatus + "unknown-federation-error" + "Unknown federation error" diff --git a/libs/wire-api-federation/src/Wire/API/Federation/GRPC/Client.hs b/libs/wire-api-federation/src/Wire/API/Federation/GRPC/Client.hs deleted file mode 100644 index 5e745e85240..00000000000 --- a/libs/wire-api-federation/src/Wire/API/Federation/GRPC/Client.hs +++ /dev/null @@ -1,61 +0,0 @@ --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2020 Wire Swiss GmbH --- --- 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 . - -module Wire.API.Federation.GRPC.Client - ( GrpcClientErr (..), - createGrpcClient, - closeGrpcClient, - grpcClientError, - ) -where - -import Control.Exception -import Control.Monad.Except -import qualified Data.Text as T -import Imports -import Mu.GRpc.Client.Record (setupGrpcClient') -import Network.GRPC.Client.Helpers - -newtype GrpcClientErr = GrpcClientErr {reason :: Text} - deriving (Show, Eq) - --- | Note: setupGrpcClient' is unsafe and throws exceptions in IO, e.g. when it can't connect. --- FUTUREWORK(federation): report setupGrpcClient' buggy behaviour to upstream. -createGrpcClient :: MonadIO m => GrpcClientConfig -> m (Either GrpcClientErr GrpcClient) -createGrpcClient cfg = do - res <- liftIO $ try @IOException $ setupGrpcClient' cfg - pure $ case res of - Left err -> Left (grpcClientError (Just cfg) err) - Right (Left err) -> Left (grpcClientError (Just cfg) err) - Right (Right client) -> Right client - --- | Close federator client and ignore errors, since the only possible error --- here is EarlyEndOfStream, which should not concern us at this point. -closeGrpcClient :: MonadIO m => GrpcClient -> m () -closeGrpcClient = void . liftIO . runExceptT . close - -grpcClientError :: Exception e => Maybe GrpcClientConfig -> e -> GrpcClientErr -grpcClientError mcfg err = - GrpcClientErr . T.pack $ - displayException err - <> maybe "" (\cfg -> " " <> addressToErrInfo (_grpcClientConfigAddress cfg)) mcfg - -addressToErrInfo :: Address -> String -addressToErrInfo = \case - AddressTCP host port -> "Host: " <> show host <> " Port: " <> show port - AddressUnix file -> "Unix Domain Socket: " <> show file - AddressSocket _sock auth -> "Socket, Authority: " <> show auth diff --git a/libs/wire-api-federation/src/Wire/API/Federation/GRPC/Types.hs b/libs/wire-api-federation/src/Wire/API/Federation/GRPC/Types.hs deleted file mode 100644 index cd59dd25d4f..00000000000 --- a/libs/wire-api-federation/src/Wire/API/Federation/GRPC/Types.hs +++ /dev/null @@ -1,211 +0,0 @@ -{-# LANGUAGE ApplicativeDo #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE RecordWildCards #-} - --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2020 Wire Swiss GmbH --- --- 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 . - -module Wire.API.Federation.GRPC.Types where - -import Data.Domain (Domain (..), domainText, mkDomain) -import Data.Either.Validation -import Data.List.NonEmpty (NonEmpty ((:|))) -import qualified Data.Text as Text -import Imports -import Mu.Quasi.GRpc (grpc) -import Mu.Schema -import Test.QuickCheck (Arbitrary (..)) -import Wire.API.Arbitrary (GenericUniform (..)) -import Wire.API.Federation.GRPC.Helper - --- Note: To understand the purpose of this file, please see the documentation of --- mu-haskell: https://higherkindness.io/mu-haskell/ - --- | Whenever proto/router.proto is changed, we want this file to recompile --- In the case of a change to one of the existing types, this will then lead to --- a compilation error (which we want to see at compilation time to keep the --- haskell code, the mu schema, and the protobuf file in sync) -recompileRouterUponProtoChanges - -grpc "Router" id routerProtoFile - -data Component - = Brig - | Galley - deriving (Typeable, Show, Eq, Generic, ToSchema Router "Component", FromSchema Router "Component") - deriving (Arbitrary) via (GenericUniform Component) - -data InwardResponse - = InwardResponseBody ByteString - | InwardResponseError InwardError - deriving (Typeable, Show, Eq, Generic) - deriving (Arbitrary) via (GenericUniform InwardResponse) - -instance ToSchema Router "InwardResponse" InwardResponse where - toSchema r = - let protoChoice = case r of - (InwardResponseError err) -> Z (FSchematic (toSchema err)) - (InwardResponseBody res) -> S (Z (FPrimitive res)) - in TRecord (Field (FUnion protoChoice) :* Nil) - -instance FromSchema Router "InwardResponse" InwardResponse where - fromSchema (TRecord (Field (FUnion protoChoice) :* Nil)) = - case protoChoice of - Z (FSchematic err) -> InwardResponseError $ fromSchema err - S (Z (FPrimitive res)) -> InwardResponseBody res - S (S x) -> - -- I don't understand why this empty case is needed, but there is some - -- explanation here: - -- https://github.com/well-typed/generics-sop/issues/116 - case x of - -data OutwardResponse - = OutwardResponseBody ByteString - | OutwardResponseError OutwardError - | OutwardResponseInwardError InwardError - deriving (Typeable, Show, Eq, Generic) - deriving (Arbitrary) via (GenericUniform OutwardResponse) - -instance ToSchema Router "OutwardResponse" OutwardResponse where - toSchema r = - let protoChoice = case r of - OutwardResponseError err -> Z (FSchematic (toSchema err)) - OutwardResponseInwardError err -> S (Z (FSchematic (toSchema err))) - OutwardResponseBody res -> S (S (Z (FPrimitive res))) - in TRecord (Field (FUnion protoChoice) :* Nil) - -instance FromSchema Router "OutwardResponse" OutwardResponse where - fromSchema (TRecord (Field (FUnion protoChoice) :* Nil)) = - case protoChoice of - Z (FSchematic err) -> OutwardResponseError $ fromSchema err - S (Z (FSchematic err)) -> OutwardResponseInwardError $ fromSchema err - S (S (Z (FPrimitive res))) -> OutwardResponseBody res - S (S (S x)) -> case x of - --- See mu-haskell Custom Mapping documentation here: --- https://higherkindness.io/mu-haskell/schema/#mapping-haskell-types -type OutwardErrorFieldMapping = - '[ "outwardErrorType" ':-> "type", - "outwardErrorMessage" ':-> "msg" - ] - -data OutwardError = OutwardError - { outwardErrorType :: OutwardErrorType, - outwardErrorMessage :: Text - } - deriving (Typeable, Show, Eq, Generic) - deriving (Arbitrary) via (GenericUniform OutwardError) - deriving - (ToSchema Router "OutwardError", FromSchema Router "OutwardError") - via (CustomFieldMapping "OutwardError" OutwardErrorFieldMapping OutwardError) - -data OutwardErrorType - = RemoteNotFound - | DiscoveryFailed - | ConnectionRefused - | TLSFailure - | VersionMismatch - | FederationDeniedByRemote - | FederationDeniedLocally - | TooMuchConcurrency - | GrpcError - | InvalidRequest - deriving (Typeable, Show, Eq, Generic, ToSchema Router "OutwardError.ErrorType", FromSchema Router "OutwardError.ErrorType") - deriving (Arbitrary) via (GenericUniform OutwardErrorType) - --- See mu-haskell Custom Mapping documentation here: --- https://higherkindness.io/mu-haskell/schema/#mapping-haskell-types -type InwardErrorFieldMapping = - '[ "inwardErrorType" ':-> "type", - "inwardErrorMsg" ':-> "msg" - ] - -data InwardError = InwardError - { inwardErrorType :: InwardErrorType, - inwardErrorMsg :: Text - } - deriving (Typeable, Show, Eq, Generic) - deriving (Arbitrary) via (GenericUniform InwardError) - deriving - (ToSchema Router "InwardError", FromSchema Router "InwardError") - via (CustomFieldMapping "InwardError" InwardErrorFieldMapping InwardError) - -data InwardErrorType - = IOther - | IAuthenticationFailed - | IFederationDeniedByRemote - | IInvalidEndpoint - | IForbiddenEndpoint - | IDiscoveryFailed - deriving (Typeable, Show, Eq, Generic, ToSchema Router "InwardError.ErrorType", FromSchema Router "InwardError.ErrorType") - deriving (Arbitrary) via (GenericUniform InwardErrorType) - --- Does this make it hard to use in a type checked way? -data Request = Request - { component :: Component, - path :: ByteString, - body :: ByteString, - originDomain :: Text - } - deriving (Typeable, Eq, Show, Generic, ToSchema Router "Request", FromSchema Router "Request") - deriving (Arbitrary) via (GenericUniform Request) - -data FederatedRequest = FederatedRequest - { domain :: Text, - request :: Maybe Request - } - deriving (Typeable, Eq, Show, Generic, ToSchema Router "FederatedRequest", FromSchema Router "FederatedRequest") - deriving (Arbitrary) via (GenericUniform FederatedRequest) - -data FederatedRequestValidationError - = InvalidDomain String - | RequestMissing - deriving (Typeable, Show, Eq) - -data ValidatedFederatedRequest = ValidatedFederatedRequest - { vDomain :: Domain, - vRequest :: Request - } - deriving (Typeable, Eq, Show) - -showFederatedRequestValidationError :: FederatedRequestValidationError -> Text -showFederatedRequestValidationError (InvalidDomain msg) = "invalid domain: " <> Text.pack msg -showFederatedRequestValidationError RequestMissing = "federation request is missing" - -showFederatedRequestValidationErrors :: NonEmpty FederatedRequestValidationError -> Text -showFederatedRequestValidationErrors = - Text.intercalate "; " - . map showFederatedRequestValidationError - . toList - -validateFederatedRequest :: FederatedRequest -> Validation (NonEmpty FederatedRequestValidationError) ValidatedFederatedRequest -validateFederatedRequest FederatedRequest {..} = do - vDomain <- validateDomain - vRequest <- validateLocalPart - pure $ ValidatedFederatedRequest {..} - where - validateDomain = case mkDomain domain of - Left str -> Failure $ InvalidDomain str :| [] - Right d -> Success d - validateLocalPart = case request of - Nothing -> Failure $ RequestMissing :| [] - Just lc -> Success lc - -validatedFederatedRequestToFederatedRequest :: ValidatedFederatedRequest -> FederatedRequest -validatedFederatedRequestToFederatedRequest ValidatedFederatedRequest {..} = FederatedRequest (domainText vDomain) (Just vRequest) diff --git a/libs/wire-api-federation/src/Wire/API/Federation/Mock.hs b/libs/wire-api-federation/src/Wire/API/Federation/Mock.hs deleted file mode 100644 index f3afde0400b..00000000000 --- a/libs/wire-api-federation/src/Wire/API/Federation/Mock.hs +++ /dev/null @@ -1,165 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE NumericUnderscores #-} - --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2021 Wire Swiss GmbH --- --- 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 . - --- | GRPC Server Mocking Machinery -module Wire.API.Federation.Mock where - -import qualified Control.Concurrent.Async as Async -import Control.Monad.Catch (MonadMask) -import qualified Control.Monad.Catch as Catch -import Control.Monad.Except (ExceptT (..), MonadError (..), runExceptT) -import Control.Monad.State (MonadState (..), gets, modify) -import qualified Data.Aeson as Aeson -import qualified Data.ByteString.Lazy as LBS -import Data.Domain (Domain) -import Data.EitherR -import qualified Data.Text as Text -import Imports -import Mu.GRpc.Client.Record (grpcClientConfigSimple) -import Mu.GRpc.Server (gRpcAppTrans, msgProtoBuf) -import Mu.Server (ServerError, ServerErrorIO, SingleServerT) -import qualified Mu.Server as Mu -import qualified Network.Wai.Handler.Warp as Warp -import System.Timeout (timeout) -import Wire.API.Federation.Client (FederatorClient, runFederatorClientWith) -import Wire.API.Federation.GRPC.Client (createGrpcClient, reason) -import Wire.API.Federation.GRPC.Types (FederatedRequest, Outward, OutwardError, OutwardResponse (OutwardResponseBody, OutwardResponseError)) - -type ReceivedRequests = [FederatedRequest] - --- FUTUREWORK: check if target domain matches the one in the request -outwardService :: SingleServerT info Outward (MockT ServerErrorIO) '[ '[FederatedRequest -> MockT ServerErrorIO OutwardResponse]] -outwardService = Mu.singleService (Mu.method @"call" callOutward) - -callOutward :: FederatedRequest -> MockT ServerErrorIO OutwardResponse -callOutward req = do - modify (\s -> s {receivedRequests = receivedRequests s <> [req]}) - resp <- gets effectfulResponse - MockT . lift $ resp req - -mkSuccessResponse :: Aeson.ToJSON a => a -> ServerErrorIO OutwardResponse -mkSuccessResponse = pure . OutwardResponseBody . LBS.toStrict . Aeson.encode - -mkErrorResponse :: OutwardError -> ServerErrorIO OutwardResponse -mkErrorResponse = pure . OutwardResponseError - -startMockFederator :: MonadIO m => IORef MockState -> ExceptT String m () -startMockFederator ref = ExceptT . liftIO $ do - (port, sock) <- Warp.openFreePort - serverStarted <- newEmptyMVar - let settings = - Warp.defaultSettings - & Warp.setPort port - & Warp.setGracefulCloseTimeout2 0 -- Defaults to 2 seconds, causes server stop to take very long - & Warp.setBeforeMainLoop (putMVar serverStarted ()) - let app = gRpcAppTrans msgProtoBuf (runMockT ref) outwardService - federatorThread <- Async.async $ Warp.runSettingsSocket settings sock app - serverStartedSignal <- timeout 10_000_000 (takeMVar serverStarted) - case serverStartedSignal of - Nothing -> do - liftIO $ Async.cancel federatorThread - pure . Left $ "Failed to start the mock server within 10 seconds on port: " <> show port - _ -> do - liftIO . modifyIORef ref $ \s -> s {serverThread = federatorThread, serverPort = toInteger port} - pure (Right ()) - -stopMockFederator :: MonadIO m => IORef MockState -> m () -stopMockFederator ref = - liftIO $ Async.cancel . serverThread <=< readIORef $ ref - -flushState :: IORef MockState -> IO () -flushState = flip modifyIORef $ \s -> s {receivedRequests = [], effectfulResponse = error "No mock response provided"} - -initState :: Domain -> MockState -initState = MockState [] (error "No mock response provided") (error "server not started") (error "No port selected yet") - --- | Run an action with access to a mock federator. --- --- The function argument `resp :: FederatedRequest -> ServerErrorIO --- OutwardResponse` can be used to provide a fake federator response for each --- possible request it is expected to receive. --- --- More explicitly, any request `req` to the federator within the provided --- action will return `resp req` as its response. -withMockFederator :: - (MonadIO m, MonadMask m) => - IORef MockState -> - (FederatedRequest -> ServerErrorIO OutwardResponse) -> - (MockState -> ExceptT String m a) -> - ExceptT String m (a, ReceivedRequests) -withMockFederator ref resp action = do - liftIO . modifyIORef ref $ \s -> s {effectfulResponse = resp} - st <- liftIO $ readIORef ref - actualResponse <- action st - st' <- liftIO $ readIORef ref - pure (actualResponse, receivedRequests st') - -withMockFederatorClient :: - (MonadIO m, MonadMask m) => - Domain -> - IORef MockState -> - (FederatedRequest -> ServerErrorIO OutwardResponse) -> - FederatorClient component (ExceptT e m) a -> - ExceptT String m (Either e a, ReceivedRequests) -withMockFederatorClient target ref resp action = withMockFederator ref resp $ \st -> do - let cfg = grpcClientConfigSimple "127.0.0.1" (fromInteger (serverPort st)) False - client <- fmapLT (Text.unpack . reason) (ExceptT (createGrpcClient cfg)) - lift . runExceptT $ - runFederatorClientWith client target (stateOrigin st) action - --- | Like 'withMockFederator', but spawn a new instance of the mock federator --- just for this action. -withTempMockFederator :: - (MonadIO m, MonadMask m) => - MockState -> - (FederatedRequest -> ServerErrorIO OutwardResponse) -> - (MockState -> ExceptT String m a) -> - ExceptT String m (a, ReceivedRequests) -withTempMockFederator st resp action = do - ref <- newIORef st - startMockFederator ref - withMockFederator ref resp action - `Catch.finally` stopMockFederator ref - -newtype MockT m a = MockT {unMock :: ReaderT (IORef MockState) m a} - deriving newtype (Functor, Applicative, Monad, MonadReader (IORef MockState), MonadIO) - -instance (MonadError ServerError m) => MonadError ServerError (MockT m) where - throwError err = MockT . lift $ throwError err - catchError action f = do - r <- ask - MockT . lift $ catchError (runMockT r action) (runMockT r . f) - -instance MonadIO m => MonadState MockState (MockT m) where - get = readIORef =<< ask - put x = do - ref <- ask - writeIORef ref x - -data MockState = MockState - { receivedRequests :: ReceivedRequests, - effectfulResponse :: FederatedRequest -> ServerErrorIO OutwardResponse, - serverThread :: Async.Async (), - serverPort :: Integer, - stateOrigin :: Domain - } - -runMockT :: IORef MockState -> MockT m a -> m a -runMockT ref mock = runReaderT (unMock mock) ref diff --git a/libs/wire-api-federation/test/Test/Wire/API/Federation/ClientSpec.hs b/libs/wire-api-federation/test/Test/Wire/API/Federation/ClientSpec.hs deleted file mode 100644 index 8ea3f3e1cfd..00000000000 --- a/libs/wire-api-federation/test/Test/Wire/API/Federation/ClientSpec.hs +++ /dev/null @@ -1,104 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# OPTIONS_GHC -Wno-partial-type-signatures #-} - --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2020 Wire Swiss GmbH --- --- 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 . - -module Test.Wire.API.Federation.ClientSpec where - -import Control.Monad.Except (ExceptT, MonadError (..), runExceptT) -import qualified Data.Aeson as Aeson -import Data.Bifunctor (first) -import qualified Data.ByteString.Lazy as LBS -import Data.Domain (Domain (Domain)) -import qualified Data.Text as Text -import Imports -import qualified Mu.Server as Mu -import Test.Hspec -import Test.QuickCheck (arbitrary, generate) -import qualified Wire.API.Federation.API.Brig as Brig -import Wire.API.Federation.Client (FederationClientError (FederationClientOutwardError, FederationClientRPCError), FederationClientFailure (..)) -import Wire.API.Federation.GRPC.Types (Component (Brig), FederatedRequest (FederatedRequest), Request (..)) -import Wire.API.Federation.Mock -import Wire.API.User (UserProfile) - -spec :: Spec -spec = do - let target = Domain "target.example.com" - stateRef <- - runIO . newIORef $ - initState (Domain "origin.example.com") - beforeAll (assertRightT (startMockFederator stateRef)) - . afterAll_ (stopMockFederator stateRef) - . before_ (flushState stateRef) - $ describe "Federator.Client" $ do - it "should make correct calls to the federator and parse success response correctly" $ do - handle <- generate arbitrary - expectedResponse :: Maybe UserProfile <- generate arbitrary - - (actualResponse, sentRequests) <- - assertRightT . withMockFederatorClient target stateRef (const (mkSuccessResponse expectedResponse)) $ - Brig.getUserByHandle Brig.clientRoutes handle - - sentRequests `shouldBe` [FederatedRequest "target.example.com" (Just $ Request Brig "/federation/get-user-by-handle" (LBS.toStrict (Aeson.encode handle)) "origin.example.com")] - actualResponse `shouldBe` Right expectedResponse - - it "should parse failure response correctly" $ do - handle <- generate arbitrary - someErr <- generate arbitrary - - (actualResponse, _) <- - assertRightT . withMockFederatorClient target stateRef (const (mkErrorResponse someErr)) $ - Brig.getUserByHandle Brig.clientRoutes handle - - first fedFailError actualResponse - `shouldBe` Left (FederationClientOutwardError someErr) - - it "should report federator failures correctly" $ do - handle <- generate arbitrary - - (actualResponse, _) <- - assertRightT . withMockFederatorClient target stateRef (error "some IO error!") $ - Brig.getUserByHandle Brig.clientRoutes handle - - case actualResponse of - Right res -> - expectationFailure $ "Expected response to be failure, got: \n" <> show res - Left (FederationClientFailure _ _ (FederationClientRPCError errText)) -> - Text.unpack errText `shouldStartWith` "grpc error: GRPC status indicates failure: status-code=INTERNAL, status-message=\"some IO error!" - Left err -> - expectationFailure $ "Expected FederationClientRPCError, got different error: \n" <> show err - - it "should report GRPC errors correctly" $ do - handle <- generate arbitrary - - (actualResponse, _) <- - assertRightT . withMockFederatorClient target stateRef (const (throwError $ Mu.ServerError Mu.NotFound "Just testing")) $ - Brig.getUserByHandle Brig.clientRoutes handle - - first fedFailError actualResponse - `shouldBe` Left (FederationClientRPCError "grpc error: GRPC status indicates failure: status-code=NOT_FOUND, status-message=\"Just testing\"") - -assertRight :: Either String b -> IO b -assertRight = \case - Left a -> do - expectationFailure $ "Expected Right, got Left: " <> a - error "impossible" - Right b -> pure b - -assertRightT :: ExceptT String IO b -> IO b -assertRightT m = runExceptT m >>= assertRight diff --git a/libs/wire-api-federation/test/Test/Wire/API/Federation/GRPC/TypesSpec.hs b/libs/wire-api-federation/test/Test/Wire/API/Federation/GRPC/TypesSpec.hs deleted file mode 100644 index 8111b5c6a46..00000000000 --- a/libs/wire-api-federation/test/Test/Wire/API/Federation/GRPC/TypesSpec.hs +++ /dev/null @@ -1,86 +0,0 @@ --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2020 Wire Swiss GmbH --- --- 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 . - -module Test.Wire.API.Federation.GRPC.TypesSpec where - -import Data.Domain (domainText, mkDomain) -import Data.Either.Validation -import Imports -import Mu.Schema (FromSchema (fromSchema), ToSchema (toSchema)) -import Test.Hspec -import Test.Hspec.QuickCheck -import Test.QuickCheck (Arbitrary (..), Gen, Property, counterexample, forAll, oneof, suchThat) -import Type.Reflection (typeRep) -import Wire.API.Federation.GRPC.Types - -spec :: Spec -spec = - describe "Wire.API.Federation.GRPC.Types" $ do - describe "Protobuf Serialization" $ do - muSchemaRoundtrip @Router @"Component" @Component - muSchemaRoundtrip @Router @"OutwardResponse" @OutwardResponse - muSchemaRoundtrip @Router @"InwardResponse" @InwardResponse - muSchemaRoundtrip @Router @"Request" @Request - muSchemaRoundtrip @Router @"FederatedRequest" @FederatedRequest - - describe "validateFederatedRequest" $ do - prop "should succeed when FederatedRequest is valid" $ do - let callGen = FederatedRequest <$> validDomain <*> (Just <$> arbitrary) - forAll callGen $ \c -> isRight' (validateFederatedRequest c) - prop "should fail appropriately when domain is not valid" $ do - let callGen = FederatedRequest <$> invalidDomain <*> arbitrary - forAll callGen $ \c -> counterexample ("validation result: " <> show (validateFederatedRequest c)) $ - case validateFederatedRequest c of - Success _ -> False - Failure errs -> - any - ( \case - InvalidDomain _ -> True - _ -> False - ) - errs - prop "should fail appropriately when request is missing" $ do - let -- Here using 'arbitrary' for generating domain will mostly generate invalid domains - callGen = FederatedRequest <$> maybeValidDomainTextGen <*> pure Nothing - forAll callGen $ \c -> counterexample ("validation result: " <> show (validateFederatedRequest c)) $ - case validateFederatedRequest c of - Success _ -> False - Failure errs -> - any - ( \case - RequestMissing -> True - _ -> False - ) - errs - -isRight' :: (Show a, Show b) => Validation a b -> Property -isRight' x = counterexample ("validation result: " <> show x) $ isRight $ validationToEither x - --- | Generates uniform distribution of valid and invalid domains -maybeValidDomainTextGen :: Gen Text -maybeValidDomainTextGen = oneof [invalidDomain, validDomain] - -validDomain :: Gen Text -validDomain = domainText <$> arbitrary - -invalidDomain :: Gen Text -invalidDomain = arbitrary `suchThat` (isLeft . mkDomain) - -muSchemaRoundtrip :: forall sch sty a. (ToSchema sch sty a, FromSchema sch sty a, Show a, Eq a, Arbitrary a, Typeable a) => Spec -muSchemaRoundtrip = - prop ("Mu Schema Roundtrip: " <> show (typeRep @a)) $ \(x :: a) -> - fromSchema (toSchema @_ @_ @sch @sty x) == x diff --git a/libs/wire-api-federation/wire-api-federation.cabal b/libs/wire-api-federation/wire-api-federation.cabal index a48cc3d7743..3de5fe24a0a 100644 --- a/libs/wire-api-federation/wire-api-federation.cabal +++ b/libs/wire-api-federation/wire-api-federation.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 502683f56cc0fbb11b75807669858c1d4fdf146afa8a016fa18daec9f6a72e7a +-- hash: 8aa2d2b311b92915ab23a4fb07be411b474f2819936b62f46e15b64c31d027fe name: wire-api-federation version: 0.1.0 @@ -17,22 +17,18 @@ copyright: (c) 2020 Wire Swiss GmbH license: AGPL-3 license-file: LICENSE build-type: Simple -extra-source-files: - proto/router.proto library exposed-modules: + Wire.API.Federation.API Wire.API.Federation.API.Brig Wire.API.Federation.API.Common Wire.API.Federation.API.Galley Wire.API.Federation.Client + Wire.API.Federation.Component Wire.API.Federation.Domain Wire.API.Federation.Error Wire.API.Federation.Event - Wire.API.Federation.GRPC.Client - Wire.API.Federation.GRPC.Helper - Wire.API.Federation.GRPC.Types - Wire.API.Federation.Mock other-modules: Paths_wire_api_federation hs-source-dirs: @@ -46,29 +42,31 @@ library , base >=4.6 && <5.0 , bytestring , bytestring-conversion + , case-insensitive + , containers , either , errors , exceptions , http-types - , http2-client-grpc + , http2 , imports , lifted-base + , metrics-wai , mtl - , mu-grpc-client - , mu-grpc-server - , mu-protobuf - , mu-rpc - , mu-schema + , network , servant >=0.16 , servant-client , servant-client-core + , servant-server , sop-core + , streaming-commons , template-haskell , text >=0.11 , time >=1.8 + , time-manager + , tls , types-common , wai-utilities - , warp , wire-api default-language: Haskell2010 @@ -77,7 +75,6 @@ test-suite spec main-is: Spec.hs other-modules: Test.Wire.API.Federation.API.BrigSpec - Test.Wire.API.Federation.ClientSpec Test.Wire.API.Federation.Golden.ConversationUpdate Test.Wire.API.Federation.Golden.GoldenSpec Test.Wire.API.Federation.Golden.LeaveConversationRequest @@ -87,7 +84,6 @@ test-suite spec Test.Wire.API.Federation.Golden.NewConnectionResponse Test.Wire.API.Federation.Golden.NewRemoteConversation Test.Wire.API.Federation.Golden.Runner - Test.Wire.API.Federation.GRPC.TypesSpec Paths_wire_api_federation hs-source-dirs: test @@ -104,35 +100,34 @@ test-suite spec , base >=4.6 && <5.0 , bytestring , bytestring-conversion + , case-insensitive , containers , either , errors , exceptions , hspec , http-types - , http2-client-grpc + , http2 , imports , lifted-base , metrics-wai , mtl - , mu-grpc-client - , mu-grpc-server - , mu-protobuf - , mu-rpc - , mu-schema , network , retry , servant >=0.16 , servant-client , servant-client-core + , servant-server , sop-core + , streaming-commons , template-haskell , text >=0.11 , time >=1.8 + , time-manager + , tls , types-common , uuid , wai-utilities - , warp , wire-api , wire-api-federation default-language: Haskell2010 diff --git a/services/brig/brig.cabal b/services/brig/brig.cabal index 8544b86ac5b..af88a6605d3 100644 --- a/services/brig/brig.cabal +++ b/services/brig/brig.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 67fbb228d01b995595cb10594e0e80b0ca794cb9ecabcd5ed8f5a894c8881de7 +-- hash: 0613764ce9b6730901fb4a909cae6c25607a3df9e7c5d97b3f51a84c80185e91 name: brig version: 1.35.0 @@ -178,7 +178,6 @@ library , mime-mail >=0.4 , mmorph , mtl >=2.1 - , mu-grpc-client , multihash >=0.1.3 , mwc-random , network >=2.4 @@ -327,6 +326,7 @@ executable brig-integration , data-timeout , email-validate , exceptions + , federator , filepath >=1.4 , galley-types , gundeck-types @@ -341,8 +341,6 @@ executable brig-integration , metrics-wai , mime >=0.4 , mtl - , mu-grpc-server - , mu-rpc , network , optparse-applicative , pem @@ -466,7 +464,6 @@ test-suite brig-tests type: exitcode-stdio-1.0 main-is: Main.hs other-modules: - Test.Brig.API.Error Test.Brig.Calling Test.Brig.Calling.Internal Test.Brig.Roundtrip diff --git a/services/brig/package.yaml b/services/brig/package.yaml index 14fbd8b3456..a0520b4412d 100644 --- a/services/brig/package.yaml +++ b/services/brig/package.yaml @@ -75,7 +75,6 @@ library: - MonadRandom >=0.5 - mmorph - mtl >=2.1 - - mu-grpc-client - multihash >=0.1.3 - mwc-random - network >=2.4 @@ -204,6 +203,7 @@ executables: - data-timeout - email-validate - exceptions + - federator - filepath >=1.4 - galley-types - gundeck-types @@ -221,8 +221,6 @@ executables: - mime >=0.4 - MonadRandom >= 0.5 - mtl - - mu-grpc-server - - mu-rpc - network - optparse-applicative - pem diff --git a/services/brig/src/Brig/API/Client.hs b/services/brig/src/Brig/API/Client.hs index e601a81ecf7..1b0280aa608 100644 --- a/services/brig/src/Brig/API/Client.hs +++ b/services/brig/src/Brig/API/Client.hs @@ -78,7 +78,7 @@ import System.Logger.Class (field, msg, val, (~~)) import qualified System.Logger.Class as Log import UnliftIO.Async (Concurrently (Concurrently, runConcurrently)) import Wire.API.Federation.API.Brig (GetUserClients (GetUserClients)) -import Wire.API.Federation.Client (FederationError (..)) +import Wire.API.Federation.Error import qualified Wire.API.Message as Message import Wire.API.Team.LegalHold (LegalholdProtectee (..)) import Wire.API.User.Client diff --git a/services/brig/src/Brig/API/Error.hs b/services/brig/src/Brig/API/Error.hs index a2c87b1b063..395b63257fc 100644 --- a/services/brig/src/Brig/API/Error.hs +++ b/services/brig/src/Brig/API/Error.hs @@ -38,7 +38,6 @@ import Network.HTTP.Types.Status import qualified Network.Wai.Utilities.Error as Wai import Servant.API.Status import Wire.API.ErrorDescription -import Wire.API.Federation.Client (FederationError (..)) import Wire.API.Federation.Error errorDescriptionToWai :: diff --git a/services/brig/src/Brig/API/Federation.hs b/services/brig/src/Brig/API/Federation.hs index 9ae84c6eeec..12bec5d32f2 100644 --- a/services/brig/src/Brig/API/Federation.hs +++ b/services/brig/src/Brig/API/Federation.hs @@ -17,7 +17,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Brig.API.Federation (federationSitemap) where +module Brig.API.Federation (federationSitemap, FederationAPI) where import qualified Brig.API.Client as API import Brig.API.Connection.Remote (performRemoteAction) @@ -42,12 +42,12 @@ import qualified Gundeck.Types.Push as Push import Imports import Network.Wai.Utilities.Error ((!>>)) import Servant (ServerT) +import Servant.API import Servant.API.Generic (ToServantApi) import Servant.Server.Generic (genericServerT) import UnliftIO.Async (pooledForConcurrentlyN_) -import Wire.API.Federation.API.Brig hiding (Api (..)) -import qualified Wire.API.Federation.API.Brig as Federated -import qualified Wire.API.Federation.API.Brig as FederationAPIBrig +import Wire.API.Federation.API.Brig hiding (BrigApi (..)) +import qualified Wire.API.Federation.API.Brig as F import Wire.API.Federation.API.Common import Wire.API.Message (UserClients) import Wire.API.Routes.Internal.Brig.Connection @@ -58,19 +58,21 @@ import Wire.API.User.Client.Prekey (ClientPrekey) import Wire.API.User.Search import Wire.API.UserMap (UserMap) -federationSitemap :: ServerT (ToServantApi Federated.Api) Handler +type FederationAPI = "federation" :> ToServantApi F.BrigApi + +federationSitemap :: ServerT FederationAPI Handler federationSitemap = genericServerT $ - FederationAPIBrig.Api - { Federated.getUserByHandle = getUserByHandle, - Federated.getUsersByIds = getUsersByIds, - Federated.claimPrekey = claimPrekey, - Federated.claimPrekeyBundle = claimPrekeyBundle, - Federated.claimMultiPrekeyBundle = claimMultiPrekeyBundle, - Federated.searchUsers = searchUsers, - Federated.getUserClients = getUserClients, - Federated.sendConnectionAction = sendConnectionAction, - Federated.onUserDeleted = onUserDeleted + F.BrigApi + { F.getUserByHandle = getUserByHandle, + F.getUsersByIds = getUsersByIds, + F.claimPrekey = claimPrekey, + F.claimPrekeyBundle = claimPrekeyBundle, + F.claimMultiPrekeyBundle = claimMultiPrekeyBundle, + F.searchUsers = searchUsers, + F.getUserClients = getUserClients, + F.sendConnectionAction = sendConnectionAction, + F.onUserDeleted = onUserDeleted } sendConnectionAction :: Domain -> NewConnectionRequest -> Handler NewConnectionResponse diff --git a/services/brig/src/Brig/API/Types.hs b/services/brig/src/Brig/API/Types.hs index a0d4244199e..83ceecba1a5 100644 --- a/services/brig/src/Brig/API/Types.hs +++ b/services/brig/src/Brig/API/Types.hs @@ -44,7 +44,7 @@ import Data.Id import Data.Qualified import Imports import qualified Network.Wai.Utilities.Error as Wai -import Wire.API.Federation.Client (FederationError) +import Wire.API.Federation.Error ------------------------------------------------------------------------------- -- Successes diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index 950b3184d5b..94c138721fa 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -150,7 +150,7 @@ import Network.Wai.Utilities import qualified System.Logger.Class as Log import System.Logger.Message import UnliftIO.Async -import Wire.API.Federation.Client (FederationError (..)) +import Wire.API.Federation.Error import Wire.API.Routes.Internal.Brig.Connection import Wire.API.Team.Member (legalHoldStatus) diff --git a/services/brig/src/Brig/App.hs b/services/brig/src/Brig/App.hs index 98fca2d7d3e..326ca0b0a24 100644 --- a/services/brig/src/Brig/App.hs +++ b/services/brig/src/Brig/App.hs @@ -132,7 +132,6 @@ import System.Logger.Class hiding (Settings, settings) import qualified System.Logger.Class as LC import qualified System.Logger.Extended as Log import Util.Options -import Wire.API.Federation.Client (HasFederatorConfig (..)) import Wire.API.User.Identity (Email) schemaVersion :: Int32 @@ -497,10 +496,6 @@ instance MonadUnliftIO m => MonadUnliftIO (AppT m) where withRunInIO $ \run -> inner (run . flip runReaderT r . unAppT) -instance HasFederatorConfig AppIO where - federatorEndpoint = view federator - federationDomain = viewFederationDomain - runAppT :: Env -> AppT m a -> m a runAppT e (AppT ma) = runReaderT ma e diff --git a/services/brig/src/Brig/Federation/Client.hs b/services/brig/src/Brig/Federation/Client.hs index 951d67b4d43..cc38a065a82 100644 --- a/services/brig/src/Brig/Federation/Client.hs +++ b/services/brig/src/Brig/Federation/Client.hs @@ -21,12 +21,14 @@ -- FUTUREWORK: Remove this module all together. module Brig.Federation.Client where -import Brig.App (AppIO) +import Brig.App import Brig.Types (PrekeyBundle) import Brig.Types.Client (PubClient) import qualified Brig.Types.Search as Public import Brig.Types.User -import Control.Monad.Trans.Except (ExceptT (..)) +import Control.Lens +import Control.Monad +import Control.Monad.Trans.Except (ExceptT (..), throwE) import Data.Domain import Data.Handle import Data.Id (ClientId, UserId) @@ -35,8 +37,10 @@ import Data.Range (Range) import qualified Data.Text as T import Imports import qualified System.Logger.Class as Log +import Wire.API.Federation.API import Wire.API.Federation.API.Brig as FederatedBrig -import Wire.API.Federation.Client (FederationError (..), executeFederated) +import Wire.API.Federation.Client +import Wire.API.Federation.Error import Wire.API.Message (UserClients) import Wire.API.User.Client (UserClientPrekeyMap) import Wire.API.User.Client.Prekey (ClientPrekey) @@ -94,7 +98,7 @@ sendConnectionAction :: sendConnectionAction self (qUntagged -> other) action = do let req = NewConnectionRequest (tUnqualified self) (qUnqualified other) action Log.info $ Log.msg @Text "Brig-federation: sending connection action to remote backend" - executeFederated (qDomain other) $ FederatedBrig.sendConnectionAction clientRoutes (tDomain self) req + executeFederated (qDomain other) $ FederatedBrig.sendConnectionAction clientRoutes req notifyUserDeleted :: Local UserId -> @@ -103,6 +107,19 @@ notifyUserDeleted :: notifyUserDeleted self remotes = do let remoteConnections = tUnqualified remotes let fedRPC = - FederatedBrig.onUserDeleted clientRoutes (tDomain self) $ + FederatedBrig.onUserDeleted clientRoutes $ UserDeletedConnectionsNotification (tUnqualified self) remoteConnections void $ executeFederated (tDomain remotes) fedRPC + +executeFederated :: Domain -> FederatorClient 'Brig a -> FederationAppIO a +executeFederated targetDomain action = do + ownDomain <- viewFederationDomain + endpoint <- view federator >>= maybe (throwE FederationNotConfigured) pure + let env = + FederatorClientEnv + { ceOriginDomain = ownDomain, + ceTargetDomain = targetDomain, + ceFederator = endpoint + } + liftIO (runFederatorClient env action) + >>= either (throwE . FederationCallFailure) pure diff --git a/services/brig/src/Brig/IO/Intra.hs b/services/brig/src/Brig/IO/Intra.hs index df063cbdd0d..d279ff05283 100644 --- a/services/brig/src/Brig/IO/Intra.hs +++ b/services/brig/src/Brig/IO/Intra.hs @@ -118,8 +118,7 @@ import Network.HTTP.Types.Status import qualified Network.Wai.Utilities.Error as Wai import System.Logger.Class as Log hiding (name, (.=)) import Wire.API.Federation.API.Brig -import Wire.API.Federation.Client -import Wire.API.Federation.Error (federationNotImplemented) +import Wire.API.Federation.Error import Wire.API.Message (UserClients) import Wire.API.Team.Feature (TeamFeatureName (..), TeamFeatureStatus) import Wire.API.Team.LegalHold (LegalholdProtectee) diff --git a/services/brig/src/Brig/Run.hs b/services/brig/src/Brig/Run.hs index dbd076d05cf..46179f9e372 100644 --- a/services/brig/src/Brig/Run.hs +++ b/services/brig/src/Brig/Run.hs @@ -24,7 +24,7 @@ module Brig.Run where import Brig.API (sitemap) -import Brig.API.Federation (federationSitemap) +import Brig.API.Federation import Brig.API.Handler import qualified Brig.API.Internal as IAPI import Brig.API.Public (ServantAPI, SwaggerDocsAPI, servantSitemap, swaggerDocsAPI) @@ -65,11 +65,9 @@ import Network.Wai.Utilities.Server import qualified Network.Wai.Utilities.Server as Server import Servant (Context ((:.)), (:<|>) (..)) import qualified Servant -import Servant.API.Generic (ToServantApi, genericApi) import System.Logger (msg, val, (.=), (~~)) import System.Logger.Class (MonadLogger, err) import Util.Options -import qualified Wire.API.Federation.API.Brig as FederationBrig -- FUTUREWORK: If any of these async threads die, we will have no clue about it -- and brig could start misbehaving. We should ensure that brig dies whenever a @@ -127,7 +125,7 @@ mkApp o = do ( swaggerDocsAPI :<|> Servant.hoistServer (Proxy @ServantAPI) (toServantHandler e) servantSitemap :<|> Servant.hoistServer (Proxy @IAPI.API) (toServantHandler e) IAPI.servantSitemap - :<|> Servant.hoistServer (genericApi (Proxy @FederationBrig.Api)) (toServantHandler e) federationSitemap + :<|> Servant.hoistServer (Proxy @FederationAPI) (toServantHandler e) federationSitemap :<|> Servant.Tagged (app e) ) @@ -135,7 +133,7 @@ type ServantCombinedAPI = ( SwaggerDocsAPI :<|> ServantAPI :<|> IAPI.API - :<|> ToServantApi FederationBrig.Api + :<|> FederationAPI :<|> Servant.Raw ) diff --git a/services/brig/test/integration/API/Federation.hs b/services/brig/test/integration/API/Federation.hs index 7f8960d7e63..a8f44b11136 100644 --- a/services/brig/test/integration/API/Federation.hs +++ b/services/brig/test/integration/API/Federation.hs @@ -26,6 +26,7 @@ import qualified Brig.Options as Opt import Brig.Types import Control.Arrow (Arrow (first), (&&&)) import Data.Aeson (encode) +import Data.Domain (Domain (Domain)) import Data.Handle (Handle (..)) import Data.Id import qualified Data.Map as Map @@ -67,7 +68,7 @@ tests m opts brig cannon fedBrigClient = test m "POST /federation/claim-multi-prekey-bundle : 200" (testClaimMultiPrekeyBundleSuccess brig fedBrigClient), test m "POST /federation/get-user-clients : 200" (testGetUserClients brig fedBrigClient), test m "POST /federation/get-user-clients : Not Found" (testGetUserClientsNotFound fedBrigClient), - test m "POST /federation/on-user-deleted/connections : 200" (testRemoteUserGetsDeleted opts brig cannon fedBrigClient) + test m "POST /federation/on-user-deleted-connections : 200" (testRemoteUserGetsDeleted opts brig cannon fedBrigClient) ] testSearchSuccess :: Brig -> FedBrigClient -> Http () @@ -86,26 +87,26 @@ testSearchSuccess brig fedBrigClient = do put (brig . path "/self" . contentJson . zUser (userId identityThief) . zConn "c" . body update) !!! const 200 === statusCode refreshIndex brig - searchResult <- FedBrig.searchUsers fedBrigClient (SearchRequest (fromHandle handle)) + searchResult <- FedBrig.searchUsers (fedBrigClient (Domain "example.com")) (SearchRequest (fromHandle handle)) liftIO $ do let contacts = contactQualifiedId <$> searchResult assertEqual "should return only the first user id but not the identityThief" [quid] contacts testSearchNotFound :: FedBrigClient -> Http () testSearchNotFound fedBrigClient = do - searchResult <- FedBrig.searchUsers fedBrigClient $ SearchRequest "this-handle-should-not-exist" + searchResult <- FedBrig.searchUsers (fedBrigClient (Domain "example.com")) $ SearchRequest "this-handle-should-not-exist" liftIO $ assertEqual "should return empty array of users" [] searchResult testSearchNotFoundEmpty :: FedBrigClient -> Http () testSearchNotFoundEmpty fedBrigClient = do - searchResult <- FedBrig.searchUsers fedBrigClient $ SearchRequest "" + searchResult <- FedBrig.searchUsers (fedBrigClient (Domain "example.com")) $ SearchRequest "" liftIO $ assertEqual "should return empty array of users" [] searchResult testGetUserByHandleSuccess :: Brig -> FedBrigClient -> Http () testGetUserByHandleSuccess brig fedBrigClient = do (handle, user) <- createUserWithHandle brig let quid = userQualifiedId user - maybeProfile <- FedBrig.getUserByHandle fedBrigClient handle + maybeProfile <- FedBrig.getUserByHandle (fedBrigClient (Domain "example.com")) handle liftIO $ do case maybeProfile of Nothing -> assertFailure "Expected to find profile, found Nothing" @@ -116,7 +117,7 @@ testGetUserByHandleSuccess brig fedBrigClient = do testGetUserByHandleNotFound :: FedBrigClient -> Http () testGetUserByHandleNotFound fedBrigClient = do hdl <- randomHandle - maybeProfile <- FedBrig.getUserByHandle fedBrigClient (Handle hdl) + maybeProfile <- FedBrig.getUserByHandle (fedBrigClient (Domain "example.com")) (Handle hdl) liftIO $ assertEqual "should not return any UserProfile" Nothing maybeProfile testGetUsersByIdsSuccess :: Brig -> FedBrigClient -> Http () @@ -127,7 +128,7 @@ testGetUsersByIdsSuccess brig fedBrigClient = do quid1 = userQualifiedId user1 uid2 = userId user2 quid2 = userQualifiedId user2 - profiles <- FedBrig.getUsersByIds fedBrigClient [uid1, uid2] + profiles <- FedBrig.getUsersByIds (fedBrigClient (Domain "example.com")) [uid1, uid2] liftIO $ do assertEqual "should return correct user Id" (Set.fromList [quid1, quid2]) (Set.fromList $ profileQualifiedId <$> profiles) assertEqual "should not have email address" [Nothing, Nothing] (map profileEmail profiles) @@ -136,7 +137,7 @@ testGetUsersByIdsPartial :: Brig -> FedBrigClient -> Http () testGetUsersByIdsPartial brig fedBrigClient = do presentUser <- randomUser brig absentUserId :: UserId <- Id <$> lift UUIDv4.nextRandom - profiles <- FedBrig.getUsersByIds fedBrigClient [userId presentUser, absentUserId] + profiles <- FedBrig.getUsersByIds (fedBrigClient (Domain "example.com")) [userId presentUser, absentUserId] liftIO $ assertEqual "should return the present user and skip the absent ones" [userQualifiedId presentUser] (profileQualifiedId <$> profiles) @@ -144,7 +145,7 @@ testGetUsersByIdsNoneFound :: FedBrigClient -> Http () testGetUsersByIdsNoneFound fedBrigClient = do absentUserId1 :: UserId <- Id <$> lift UUIDv4.nextRandom absentUserId2 :: UserId <- Id <$> lift UUIDv4.nextRandom - profiles <- FedBrig.getUsersByIds fedBrigClient [absentUserId1, absentUserId2] + profiles <- FedBrig.getUsersByIds (fedBrigClient (Domain "example.com")) [absentUserId1, absentUserId2] liftIO $ assertEqual "should return empty list" [] profiles @@ -154,7 +155,7 @@ testClaimPrekeySuccess brig fedBrigClient = do let uid = userId user let new = defNewClient PermanentClientType [head somePrekeys] (head someLastPrekeys) c <- responseJsonError =<< addClient brig uid new - mkey <- FedBrig.claimPrekey fedBrigClient (uid, clientId c) + mkey <- FedBrig.claimPrekey (fedBrigClient (Domain "example.com")) (uid, clientId c) liftIO $ assertEqual "should return prekey 1" @@ -166,7 +167,7 @@ testClaimPrekeyBundleSuccess brig fedBrigClient = do let prekeys = take 5 (zip somePrekeys someLastPrekeys) (quid, clients) <- generateClientPrekeys brig prekeys let sortClients = sortBy (compare `on` prekeyClient) - bundle <- FedBrig.claimPrekeyBundle fedBrigClient (qUnqualified quid) + bundle <- FedBrig.claimPrekeyBundle (fedBrigClient (Domain "example.com")) (qUnqualified quid) liftIO $ assertEqual "bundle should contain the clients" @@ -184,7 +185,7 @@ testClaimMultiPrekeyBundleSuccess brig fedBrigClient = do c2 <- first qUnqualified <$> generateClientPrekeys brig prekeys2 let uc = UserClients (Map.fromList [mkClients <$> c1, mkClients <$> c2]) ucm = mkUserClientPrekeyMap (Map.fromList [mkClientMap <$> c1, mkClientMap <$> c2]) - ucmResponse <- FedBrig.claimMultiPrekeyBundle fedBrigClient uc + ucmResponse <- FedBrig.claimMultiPrekeyBundle (fedBrigClient (Domain "example.com")) uc liftIO $ assertEqual "should return the UserClientMap" @@ -202,7 +203,7 @@ testGetUserClients :: Brig -> FedBrigClient -> Http () testGetUserClients brig fedBrigClient = do uid1 <- userId <$> randomUser brig clients :: [Client] <- addTestClients brig uid1 [0, 1, 2] - UserMap userClients <- FedBrig.getUserClients fedBrigClient (GetUserClients [uid1]) + UserMap userClients <- FedBrig.getUserClients (fedBrigClient (Domain "example.com")) (GetUserClients [uid1]) liftIO $ assertEqual "client set for user should match" @@ -212,7 +213,7 @@ testGetUserClients brig fedBrigClient = do testGetUserClientsNotFound :: FedBrigClient -> Http () testGetUserClientsNotFound fedBrigClient = do absentUserId <- randomId - UserMap userClients <- FedBrig.getUserClients fedBrigClient (GetUserClients [absentUserId]) + UserMap userClients <- FedBrig.getUserClients (fedBrigClient (Domain "example.com")) (GetUserClients [absentUserId]) liftIO $ assertEqual "client set for user should match" @@ -236,8 +237,7 @@ testRemoteUserGetsDeleted opts brig cannon fedBrigClient = do void . WS.bracketRN cannon localUsers $ \[cc, pc, bc, uc] -> do _ <- FedBrig.onUserDeleted - fedBrigClient - (qDomain remoteUser) + (fedBrigClient (qDomain remoteUser)) (UserDeletedConnectionsNotification (qUnqualified remoteUser) (unsafeRange localUsers)) WS.assertMatchN_ (5 # Second) [cc] $ matchDeleteUserNotification remoteUser diff --git a/services/brig/test/integration/API/Search.hs b/services/brig/test/integration/API/Search.hs index 1febe169a7d..1cb3a2a5ba3 100644 --- a/services/brig/test/integration/API/Search.hs +++ b/services/brig/test/integration/API/Search.hs @@ -56,7 +56,6 @@ import Test.Tasty.HUnit import Text.RawString.QQ (r) import UnliftIO (Concurrently (..), runConcurrently) import Util -import Wire.API.Federation.GRPC.Types import Wire.API.Team.Feature (TeamFeatureStatusValue (..)) tests :: Opt.Opts -> Manager -> Galley -> Brig -> IO TestTree @@ -449,7 +448,7 @@ testSearchOtherDomain opts brig = do -- We cannot assert on a real federated request here, so we make a request to -- a mocked federator started and stopped during this test otherSearchResult :: [Contact] <- liftIO $ generate arbitrary - let mockResponse = OutwardResponseBody (cs $ Aeson.encode otherSearchResult) + let mockResponse = Aeson.encode otherSearchResult (results, _) <- liftIO . withTempMockFederator opts mockResponse $ do executeSearchWithDomain brig (userId user) "someSearchText" (Domain "non-existent.example.com") let expectedResult = diff --git a/services/brig/test/integration/API/User/Account.hs b/services/brig/test/integration/API/User/Account.hs index 78dd97bda49..a232151fa5a 100644 --- a/services/brig/test/integration/API/User/Account.hs +++ b/services/brig/test/integration/API/User/Account.hs @@ -36,6 +36,7 @@ import Brig.Types.User.Auth hiding (user) import qualified Brig.Types.User.Auth as Auth import qualified CargoHold.Types.V3 as CHV3 import Control.Arrow ((&&&)) +import Control.Exception (throw) import Control.Lens (ix, preview, (^.), (^?)) import Control.Monad.Catch import Data.Aeson @@ -45,7 +46,7 @@ import qualified Data.Aeson.Lens as AesonL import qualified Data.ByteString as C8 import Data.ByteString.Char8 (pack) import Data.ByteString.Conversion -import Data.Domain (Domain (..), domainText) +import Data.Domain import Data.Id hiding (client) import Data.Json.Util (fromUTCTimeMillis) import Data.List1 (singleton) @@ -63,6 +64,7 @@ import qualified Data.UUID as UUID import qualified Data.UUID.V4 as UUID import Data.Vector (Vector) import qualified Data.Vector as Vec +import Federator.MockServer (FederatedRequest (..), MockException (..)) import Galley.Types.Teams (noPermissions) import Gundeck.Types.Notification import Imports hiding (head) @@ -80,8 +82,6 @@ import Web.Cookie (parseSetCookie) import Wire.API.Federation.API.Brig (UserDeletedConnectionsNotification (..)) import qualified Wire.API.Federation.API.Brig as FedBrig import Wire.API.Federation.API.Common (EmptyResponse (EmptyResponse)) -import Wire.API.Federation.GRPC.Types (OutwardResponse (OutwardResponseBody)) -import qualified Wire.API.Federation.GRPC.Types as F import Wire.API.User (ListUsersQuery (..)) import Wire.API.User.Identity (mkSampleUref, mkSimpleSampleUref) @@ -1225,7 +1225,7 @@ testDeleteWithRemotes opts brig = do sendConnectionAction brig opts (userId localUser) remote2UserBlocked (Just FedBrig.RemoteConnect) Accepted void $ putConnectionQualified brig (userId localUser) remote2UserBlocked Blocked - let fedMockResponse = const (OutwardResponseBody (cs $ Aeson.encode EmptyResponse)) + let fedMockResponse _ = pure (Aeson.encode EmptyResponse) let galleyHandler :: ReceivedRequest -> MockT IO Wai.Response galleyHandler (ReceivedRequest requestMethod requestPath _requestBody) = case (requestMethod, requestPath) of @@ -1240,23 +1240,19 @@ testDeleteWithRemotes opts brig = do const 200 === statusCode liftIO $ do - remote1Call <- assertOne $ filter (\c -> F.domain c == domainText remote1Domain) rpcCalls + remote1Call <- assertOne $ filter (\c -> frTargetDomain c == remote1Domain) rpcCalls remote1Udn <- assertRight $ parseFedRequest remote1Call udcnUser remote1Udn @?= userId localUser sort (fromRange (udcnConnections remote1Udn)) @?= sort (map qUnqualified [remote1UserConnected, remote1UserPending]) - remote2Call <- assertOne $ filter (\c -> F.domain c == domainText remote2Domain) rpcCalls + remote2Call <- assertOne $ filter (\c -> frTargetDomain c == remote2Domain) rpcCalls remote2Udn <- assertRight $ parseFedRequest remote2Call udcnUser remote2Udn @?= userId localUser fromRange (udcnConnections remote2Udn) @?= [qUnqualified remote2UserBlocked] where - parseFedRequest :: FromJSON a => F.FederatedRequest -> Either String a - parseFedRequest fr = - case F.request fr of - Just r -> - (eitherDecode . cs) (F.body r) - Nothing -> Left "No request" + parseFedRequest :: FromJSON a => FederatedRequest -> Either String a + parseFedRequest = eitherDecode . frBody testDeleteWithRemotesAndFailedNotifications :: Opt.Opts -> Brig -> Cannon -> Http () testDeleteWithRemotesAndFailedNotifications opts brig cannon = do @@ -1275,9 +1271,9 @@ testDeleteWithRemotesAndFailedNotifications opts brig cannon = do sendConnectionAction brig opts (userId alice) carl (Just FedBrig.RemoteConnect) Accepted let fedMockResponse req = - if Domain (F.domain req) == bDomain - then F.OutwardResponseError (F.OutwardError F.ConnectionRefused "mocked connection problem with b domain") - else OutwardResponseBody (cs $ Aeson.encode EmptyResponse) + if frTargetDomain req == bDomain + then throw $ MockErrorResponse Http.status500 "mocked connection problem with b domain" + else pure (Aeson.encode EmptyResponse) let galleyHandler :: ReceivedRequest -> MockT IO Wai.Response galleyHandler (ReceivedRequest requestMethod requestPath _requestBody) = @@ -1295,18 +1291,14 @@ testDeleteWithRemotesAndFailedNotifications opts brig cannon = do void . liftIO . WS.assertMatch (5 # Second) wsAlex $ matchDeleteUserNotification (userQualifiedId alice) liftIO $ do - rRpc <- assertOne $ filter (\c -> F.domain c == domainText cDomain) rpcCalls + rRpc <- assertOne $ filter (\c -> frTargetDomain c == cDomain) rpcCalls cUdn <- assertRight $ parseFedRequest rRpc udcnUser cUdn @?= userId alice sort (fromRange (udcnConnections cUdn)) @?= sort (map qUnqualified [carl]) where - parseFedRequest :: FromJSON a => F.FederatedRequest -> Either String a - parseFedRequest fr = - case F.request fr of - Just r -> - (eitherDecode . cs) (F.body r) - Nothing -> Left "No request" + parseFedRequest :: FromJSON a => FederatedRequest -> Either String a + parseFedRequest = eitherDecode . frBody testUpdateSSOId :: Brig -> Galley -> Http () testUpdateSSOId brig galley = do diff --git a/services/brig/test/integration/API/User/Connection.hs b/services/brig/test/integration/API/User/Connection.hs index 1a22019afed..199d41228d7 100644 --- a/services/brig/test/integration/API/User/Connection.hs +++ b/services/brig/test/integration/API/User/Connection.hs @@ -727,7 +727,7 @@ testConnectWithAnon :: Brig -> FedBrigClient -> Http () testConnectWithAnon brig fedBrigClient = do fromUser <- randomId toUser <- userId <$> createAnonUser "anon1234" brig - res <- F.sendConnectionAction fedBrigClient (Domain "far-away.example.com") (F.NewConnectionRequest fromUser toUser F.RemoteConnect) + res <- F.sendConnectionAction (fedBrigClient (Domain "far-away.example.com")) (F.NewConnectionRequest fromUser toUser F.RemoteConnect) liftIO $ assertEqual "The response should specify that the user is not activated" F.NewConnectionResponseUserNotActivated res @@ -781,7 +781,7 @@ testConnectMutualRemoteActionThenLocalAction opts brig fedBrigClient fedGalleyCl gcrConvIds = [qUnqualified convId] } - res <- F.getConversations fedGalleyClient (qDomain quid2) request + res <- F.getConversations (fedGalleyClient (qDomain quid2)) request liftIO $ fmap (fmap omQualifiedId . rcmOthers . rcnvMembers) (gcresConvs res) @?= [[]] diff --git a/services/brig/test/integration/API/User/Util.hs b/services/brig/test/integration/API/User/Util.hs index a3024bde91c..6e8087c4961 100644 --- a/services/brig/test/integration/API/User/Util.hs +++ b/services/brig/test/integration/API/User/Util.hs @@ -37,17 +37,17 @@ import Data.ByteString.Builder (toLazyByteString) import Data.ByteString.Char8 (pack) import Data.ByteString.Conversion import qualified Data.ByteString.Lazy as LB -import Data.Domain (Domain, domainText) +import Data.Domain import Data.Handle (Handle (Handle)) import Data.Id hiding (client) import qualified Data.List1 as List1 import Data.Misc (PlainTextPassword (..)) import Data.Qualified import Data.Range (unsafeRange) -import Data.String.Conversions (cs) import qualified Data.Text.Ascii as Ascii import qualified Data.Vector as Vec import Federation.Util (withTempMockFederator) +import Federator.MockServer (FederatedRequest (..)) import Gundeck.Types (Notification (..)) import Imports import qualified Test.Tasty.Cannon as WS @@ -55,8 +55,7 @@ import Test.Tasty.HUnit import Util import qualified Wire.API.Event.Conversation as Conv import qualified Wire.API.Federation.API.Brig as F -import Wire.API.Federation.GRPC.Types hiding (body, path) -import qualified Wire.API.Federation.GRPC.Types as F +import Wire.API.Federation.Component import Wire.API.Routes.Internal.Brig.Connection import Wire.API.Routes.MultiTablePaging (LocalOrRemoteTable, MultiTablePagingState) @@ -346,7 +345,7 @@ receiveConnectionAction :: Http () receiveConnectionAction brig fedBrigClient uid1 quid2 action expectedReaction expectedRel = do res <- - F.sendConnectionAction fedBrigClient (qDomain quid2) $ + F.sendConnectionAction (fedBrigClient (qDomain quid2)) $ F.NewConnectionRequest (qUnqualified quid2) uid1 action liftIO $ do res @?= F.NewConnectionResponseOk expectedReaction @@ -363,18 +362,18 @@ sendConnectionAction :: Http () sendConnectionAction brig opts uid1 quid2 reaction expectedRel = do let mockConnectionResponse = F.NewConnectionResponseOk reaction - mockResponse = OutwardResponseBody (cs $ encode mockConnectionResponse) + mockResponse = encode mockConnectionResponse (res, reqs) <- liftIO . withTempMockFederator opts mockResponse $ postConnectionQualified brig uid1 quid2 liftIO $ do req <- assertOne reqs - F.domain req @?= domainText (qDomain quid2) - fmap F.component (F.request req) @?= Just F.Brig - fmap F.path (F.request req) @?= Just "/federation/send-connection-action" - eitherDecode . cs . F.body <$> F.request req - @?= Just (Right (F.NewConnectionRequest uid1 (qUnqualified quid2) F.RemoteConnect)) + frTargetDomain req @?= qDomain quid2 + frComponent req @?= Brig + frRPC req @?= "send-connection-action" + eitherDecode (frBody req) + @?= Right (F.NewConnectionRequest uid1 (qUnqualified quid2) F.RemoteConnect) liftIO $ assertBool "postConnectionQualified failed" $ statusCode res `elem` [200, 201] assertConnectionQualified brig uid1 quid2 expectedRel @@ -390,7 +389,7 @@ sendConnectionUpdateAction :: Http () sendConnectionUpdateAction brig opts uid1 quid2 reaction expectedRel = do let mockConnectionResponse = F.NewConnectionResponseOk reaction - mockResponse = OutwardResponseBody (cs $ encode mockConnectionResponse) + mockResponse = encode mockConnectionResponse void $ liftIO . withTempMockFederator opts mockResponse $ putConnectionQualified brig uid1 quid2 expectedRel !!! const 200 === statusCode diff --git a/services/brig/test/integration/Federation/End2end.hs b/services/brig/test/integration/Federation/End2end.hs index 445fa1ab7c8..9affa5d1d3d 100644 --- a/services/brig/test/integration/Federation/End2end.hs +++ b/services/brig/test/integration/Federation/End2end.hs @@ -105,7 +105,7 @@ spec _brigOpts mg brig galley cannon _federator brigTwo galleyTwo = -- | Path covered by this test: -- -- +------+ +---------+ +---------+ +------+ --- | brig | grpc |federator| grpc |federator| http | brig | +-- | brig | http2 |federator| http2 |federator| http | brig | -- | +-------->+ +------->+ +--------->+ | -- +------+ +-+-------+ +---------+ +------+ testHandleLookup :: Brig -> Brig -> Http () diff --git a/services/brig/test/integration/Federation/Util.hs b/services/brig/test/integration/Federation/Util.hs index 67611a79df4..e3cb6378b7d 100644 --- a/services/brig/test/integration/Federation/Util.hs +++ b/services/brig/test/integration/Federation/Util.hs @@ -44,13 +44,11 @@ import Data.Qualified (Qualified (..)) import Data.String.Conversions (cs) import qualified Data.Text as Text import qualified Database.Bloodhound as ES +import qualified Federator.MockServer as Mock import Foreign.C.Error (Errno (..), eCONNREFUSED) import GHC.IO.Exception (IOException (ioe_errno)) import qualified Galley.Types.Teams.SearchVisibility as Team import Imports -import Mu.GRpc.Server (msgProtoBuf, runGRpcApp) -import Mu.Server (ServerErrorIO, SingleServerT) -import qualified Mu.Server as Mu import qualified Network.HTTP.Client as HTTP import Network.Socket import Network.Wai.Handler.Warp (Port) @@ -66,36 +64,23 @@ import Util.Options (Endpoint (Endpoint)) import Wire.API.Conversation (Conversation (cnvMembers)) import Wire.API.Conversation.Member (OtherMember (OtherMember), cmOthers) import Wire.API.Conversation.Role (roleNameWireAdmin) -import Wire.API.Federation.GRPC.Types (FederatedRequest, Outward, OutwardResponse (..)) -import qualified Wire.API.Federation.Mock as Mock import Wire.API.Team.Feature (TeamFeatureStatusValue (..)) --- | Starts a grpc server which will return the 'OutwardResponse' passed to this +-- | Starts a server which will return the bytestring passed to this -- function, and makes the action passed to this function run in a modified brig -- which will contact this mocked federator instead of a real federator. -withMockFederator :: Opt.Opts -> IORef Mock.MockState -> OutwardResponse -> Session a -> IO (a, Mock.ReceivedRequests) -withMockFederator opts ref resp action = assertRightT - . Mock.withMockFederator ref (const (pure resp)) - $ \st -> lift $ do - let opts' = - opts - { Opt.federatorInternal = - Just (Endpoint "127.0.0.1" (fromIntegral (Mock.serverPort st))) - } - withSettingsOverrides opts' action - -withTempMockFederator :: Opt.Opts -> OutwardResponse -> Session a -> IO (a, Mock.ReceivedRequests) -withTempMockFederator opts resp action = assertRightT - . Mock.withTempMockFederator st0 (const (pure resp)) - $ \st -> lift $ do - let opts' = - opts - { Opt.federatorInternal = - Just (Endpoint "127.0.0.1" (fromIntegral (Mock.serverPort st))) - } - withSettingsOverrides opts' action - where - st0 = Mock.initState (Domain "example.com") +withTempMockFederator :: Opt.Opts -> LByteString -> Session a -> IO (a, [Mock.FederatedRequest]) +withTempMockFederator opts resp action = + Mock.withTempMockFederator + [("Content-Type", "application/json")] + (const (pure resp)) + $ \mockPort -> do + let opts' = + opts + { Opt.federatorInternal = + Just (Endpoint "127.0.0.1" (fromIntegral mockPort)) + } + withSettingsOverrides opts' action generateClientPrekeys :: Brig -> [(Prekey, LastPrekey)] -> Http (Qualified UserId, [ClientPrekey]) generateClientPrekeys brig prekeys = do diff --git a/services/brig/test/integration/Main.hs b/services/brig/test/integration/Main.hs index 9380b84a4f8..b3784d8d114 100644 --- a/services/brig/test/integration/Main.hs +++ b/services/brig/test/integration/Main.hs @@ -38,6 +38,8 @@ import qualified Brig.Options as Opts import Cassandra.Util (defInitCassandra) import Control.Lens import Data.Aeson +import Data.ByteString.Conversion +import Data.Domain import Data.Metrics.Test (pathsConsistencyCheck) import Data.Metrics.WaiRoute (treeToPaths) import qualified Data.Text as Text @@ -46,13 +48,15 @@ import Data.Yaml (decodeFileEither) import qualified Federation.End2end import Imports hiding (local) import qualified Index.Create +import qualified Network.HTTP.Client as HTTP import Network.HTTP.Client.TLS (tlsManagerSettings) import Network.Wai.Utilities.Server (compile) import OpenSSL (withOpenSSL) import Options.Applicative hiding (action) import Servant.API.Generic (GenericServant, ToServant, ToServantApi) -import Servant.Client (HasClient) import qualified Servant.Client as Servant +import Servant.Client.Core +import qualified Servant.Client.Core.Request as Client import Servant.Client.Generic (AsClientT) import qualified Servant.Client.Generic as Servant import System.Environment (withArgs) @@ -63,8 +67,9 @@ import Test.Tasty.HUnit import Util (FedBrigClient, FedGalleyClient) import Util.Options import Util.Test -import qualified Wire.API.Federation.API.Brig as FedBrig -import qualified Wire.API.Federation.API.Galley as FedGalley +import qualified Wire.API.Federation.API.Brig as F +import qualified Wire.API.Federation.API.Galley as F +import Wire.API.Federation.Domain data BackendConf = BackendConf { remoteBrig :: Endpoint, @@ -220,10 +225,10 @@ parseConfigPaths = do ) mkFedBrigClient :: Manager -> Endpoint -> FedBrigClient -mkFedBrigClient = mkFedBrigClientGen @FedBrig.Api +mkFedBrigClient = mkFedBrigClientGen @F.BrigApi mkFedGalleyClient :: Manager -> Endpoint -> FedGalleyClient -mkFedGalleyClient = mkFedBrigClientGen @FedGalley.Api +mkFedGalleyClient = mkFedBrigClientGen @F.GalleyApi mkFedBrigClientGen :: forall routes. @@ -233,16 +238,25 @@ mkFedBrigClientGen :: ) => Manager -> Endpoint -> + Domain -> routes (AsClientT (HttpT IO)) -mkFedBrigClientGen mgr endpoint = Servant.genericClientHoist servantClienMToHttp +mkFedBrigClientGen mgr endpoint originDomain = Servant.genericClientHoist servantClientMToHttp where - servantClienMToHttp :: Servant.ClientM a -> Http a - servantClienMToHttp action = liftIO $ do + servantClientMToHttp :: Servant.ClientM a -> Http a + servantClientMToHttp action = liftIO $ do let brigHost = Text.unpack $ endpoint ^. epHost brigPort = fromInteger . toInteger $ endpoint ^. epPort - baseUrl = Servant.BaseUrl Servant.Http brigHost brigPort "" - clientEnv = Servant.ClientEnv mgr baseUrl Nothing Servant.defaultMakeClientRequest + baseUrl = Servant.BaseUrl Servant.Http brigHost brigPort "/federation" + clientEnv = Servant.ClientEnv mgr baseUrl Nothing makeClientRequest eitherRes <- Servant.runClientM action clientEnv case eitherRes of Right res -> pure res Left err -> assertFailure $ "Servant client failed with: " <> show err + + makeClientRequest :: BaseUrl -> Client.Request -> HTTP.Request + makeClientRequest burl req = + let req' = Servant.defaultMakeClientRequest burl req + in req' + { HTTP.requestHeaders = + HTTP.requestHeaders req' <> [(originDomainHeaderName, toByteString' originDomain)] + } diff --git a/services/brig/test/integration/Util.hs b/services/brig/test/integration/Util.hs index 5a3ca0781b4..2b9879c7d91 100644 --- a/services/brig/test/integration/Util.hs +++ b/services/brig/test/integration/Util.hs @@ -65,6 +65,7 @@ import qualified Data.Text.Ascii as Ascii import Data.Text.Encoding (encodeUtf8) import qualified Data.UUID as UUID import qualified Data.UUID.V4 as UUID +import qualified Federator.MockServer as Mock import Galley.Types.Conversations.One2One (one2OneConvId) import qualified Galley.Types.Teams as Team import Gundeck.Types.Notification @@ -87,10 +88,8 @@ import Util.AWS import Util.Options (Endpoint (Endpoint)) import Wire.API.Conversation import Wire.API.Conversation.Role (roleNameWireAdmin) -import qualified Wire.API.Federation.API.Brig as FedBrig -import qualified Wire.API.Federation.API.Galley as FedGalley -import Wire.API.Federation.GRPC.Types (FederatedRequest, OutwardResponse) -import qualified Wire.API.Federation.Mock as Mock +import qualified Wire.API.Federation.API.Brig as F +import qualified Wire.API.Federation.API.Galley as F import Wire.API.Routes.MultiTablePaging type Brig = Request -> Request @@ -107,9 +106,9 @@ type Nginz = Request -> Request type Spar = Request -> Request -type FedBrigClient = FedBrig.Api (AsClientT (HttpT IO)) +type FedBrigClient = Domain -> F.BrigApi (AsClientT (HttpT IO)) -type FedGalleyClient = FedGalley.Api (AsClientT (HttpT IO)) +type FedGalleyClient = Domain -> F.GalleyApi (AsClientT (HttpT IO)) instance ToJSON SESBounceType where toJSON BounceUndetermined = String "Undetermined" @@ -1039,21 +1038,21 @@ withMockedGalley opts handler action = withMockedFederatorAndGalley :: Opt.Opts -> Domain -> - (FederatedRequest -> OutwardResponse) -> + (Mock.FederatedRequest -> IO LByteString) -> (ReceivedRequest -> MockT IO Wai.Response) -> Session a -> - IO (a, Mock.ReceivedRequests, [ReceivedRequest]) -withMockedFederatorAndGalley opts domain fedResp galleyHandler action = do + IO (a, [Mock.FederatedRequest], [ReceivedRequest]) +withMockedFederatorAndGalley opts _domain fedResp galleyHandler action = do result <- assertRight <=< runExceptT $ withTempMockedService initState galleyHandler $ \galleyMockState -> - Mock.withTempMockFederator (Mock.initState domain) (pure . fedResp) $ \fedMockState -> do + Mock.withTempMockFederator [("Content-Type", "application/json")] fedResp $ \fedMockPort -> do let opts' = opts { Opt.galley = Endpoint "127.0.0.1" (fromIntegral (serverPort galleyMockState)), - Opt.federatorInternal = Just (Endpoint "127.0.0.1" (fromIntegral (Mock.serverPort fedMockState))) + Opt.federatorInternal = Just (Endpoint "127.0.0.1" (fromIntegral fedMockPort)) } withSettingsOverrides opts' action pure (combineResults result) where - combineResults :: ((a, Mock.ReceivedRequests), [ReceivedRequest]) -> (a, Mock.ReceivedRequests, [ReceivedRequest]) + combineResults :: ((a, [Mock.FederatedRequest]), [ReceivedRequest]) -> (a, [Mock.FederatedRequest], [ReceivedRequest]) combineResults ((a, mrr), rr) = (a, mrr, rr) diff --git a/services/brig/test/unit/Main.hs b/services/brig/test/unit/Main.hs index a3137ba25de..ea675ebe300 100644 --- a/services/brig/test/unit/Main.hs +++ b/services/brig/test/unit/Main.hs @@ -21,7 +21,6 @@ module Main where import Imports -import qualified Test.Brig.API.Error import qualified Test.Brig.Calling import qualified Test.Brig.Calling.Internal import qualified Test.Brig.Roundtrip @@ -36,6 +35,5 @@ main = [ Test.Brig.User.Search.Index.Types.tests, Test.Brig.Calling.tests, Test.Brig.Calling.Internal.tests, - Test.Brig.API.Error.tests, Test.Brig.Roundtrip.tests ] diff --git a/services/brig/test/unit/Test/Brig/API/Error.hs b/services/brig/test/unit/Test/Brig/API/Error.hs deleted file mode 100644 index 18b21af6353..00000000000 --- a/services/brig/test/unit/Test/Brig/API/Error.hs +++ /dev/null @@ -1,113 +0,0 @@ -module Test.Brig.API.Error where - -import Brig.API.Error -import Data.Domain -import Imports -import qualified Network.HTTP.Types as HTTP -import qualified Network.Wai.Utilities as Wai -import qualified Servant.Client.Core as Servant -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (assertEqual, testCase) -import Wire.API.Federation.Client -import Wire.API.Federation.Error -import qualified Wire.API.Federation.GRPC.Types as Proto - -tests :: TestTree -tests = testGroup "Brig.API.Error" [testFedError, testOutwardError] - -testFedError :: TestTree -testFedError = - testGroup - "fedEror" - [ testCase "when federation is unavailable" $ - assertFedErrorStatus (FederationUnavailable "federator down!") 500, - testCase "when federation is not implemented" $ - assertFedErrorStatus FederationNotImplemented 403, - testCase "when federation is not configured" $ - assertFedErrorStatus FederationNotConfigured 400, - testCase "when federation call fails due to RPC error" $ - assertFedErrorStatus (mkFailure (FederationClientRPCError "some failure")) 500, - testCase "when federation call fails due wrong method" $ - assertFedErrorStatus (mkFailure (FederationClientInvalidMethod "GET")) 500, - testCase "when federation call fails due to requesting streaming" $ - assertFedErrorStatus (mkFailure FederationClientStreamingUnsupported) 500, - testCase "when federation call fails due to discovery failure" $ do - let outwardErr = FederationClientOutwardError (Proto.OutwardError Proto.DiscoveryFailed "discovery failed") - assertFedErrorStatus (mkFailure outwardErr) 500, - testCase "when federation call fails due to decode failure" $ - assertFedErrorStatus (mkFailure (FederationClientServantError (Servant.DecodeFailure "some failure" emptyRes))) 533, - testCase "when federation call fails due to Servant.FailureResponse" $ - assertFedErrorStatus (mkFailure (FederationClientServantError (Servant.FailureResponse emptyReq emptyRes))) 533, - testCase "when federation call fails due to invalid content type" $ - assertFedErrorStatus (mkFailure (FederationClientServantError (Servant.InvalidContentTypeHeader emptyRes))) 533, - testCase "when federation call fails due to unsupported content type" $ - assertFedErrorStatus (mkFailure (FederationClientServantError (Servant.UnsupportedContentType "application/xml" emptyRes))) 533, - testCase "when federation call fails due to connection error" $ - assertFedErrorStatus (mkFailure (FederationClientServantError (Servant.ConnectionError (SomeException TestException)))) 500 - ] - -testOutwardError :: TestTree -testOutwardError = - testGroup "federationRemoteError" $ - [ testGroup "status" $ - [ testCase "when remote is not found" $ - assertOutwardErrorStatus Proto.RemoteNotFound 422, - testCase "when discovery fails" $ - assertOutwardErrorStatus Proto.DiscoveryFailed 500, - testCase "when connection is refused" $ - assertOutwardErrorStatus Proto.ConnectionRefused 521, - testCase "when TLS fails" $ - assertOutwardErrorStatus Proto.TLSFailure 525, - testCase "when remote returns version mismatch" $ - assertOutwardErrorStatus Proto.VersionMismatch 531, - testCase "when remote denies federation" $ - assertOutwardErrorStatus Proto.FederationDeniedByRemote 532, - testCase "when local federator denies federation" $ - assertOutwardErrorStatus Proto.FederationDeniedLocally 400, - testCase "when there is too much concurrency" $ - assertOutwardErrorStatus Proto.TooMuchConcurrency 533, - testCase "when gRPC fails" $ - assertOutwardErrorStatus Proto.GrpcError 533, - testCase "when federator returns invalid request" $ - assertOutwardErrorStatus Proto.InvalidRequest 500 - ], - testCase "error message" $ do - let outwardErr = Proto.OutwardError Proto.TLSFailure "something went wrong" - waiErr = federationRemoteError outwardErr - assertEqual "message should be copied" (Wai.message waiErr) "something went wrong" - ] - -mkFailure :: FederationClientError -> FederationError -mkFailure = - FederationCallFailure - . FederationClientFailure (Domain "far-away.example.com") "/federation/test" - -assertFedErrorStatus :: HasCallStack => FederationError -> Int -> IO () -assertFedErrorStatus err sts = assertEqual ("http status should be " <> show sts) (statusFor err) sts - -assertOutwardErrorStatus :: HasCallStack => Proto.OutwardErrorType -> Int -> IO () -assertOutwardErrorStatus errType sts = - assertEqual ("http status should be " <> show sts) (HTTP.statusCode . Wai.code . federationRemoteError $ Proto.OutwardError errType mempty) sts - -statusFor :: FederationError -> Int -statusFor = HTTP.statusCode . errorStatus . fedError - -emptyReq :: Servant.RequestF () (Servant.BaseUrl, ByteString) -emptyReq = - Servant.Request - { Servant.requestPath = (Servant.BaseUrl Servant.Http "" 0 "", ""), - Servant.requestQueryString = mempty, - Servant.requestBody = Nothing, - Servant.requestAccept = mempty, - Servant.requestHeaders = mempty, - Servant.requestHttpVersion = HTTP.http11, - Servant.requestMethod = HTTP.methodGet - } - -emptyRes :: Servant.Response -emptyRes = Servant.Response HTTP.status200 mempty HTTP.http11 "" - -data TestException = TestException - deriving (Show, Eq) - -instance Exception TestException diff --git a/services/federator/federator.cabal b/services/federator/federator.cabal index 7bd2efef164..fca3d7731cf 100644 --- a/services/federator/federator.cabal +++ b/services/federator/federator.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 9cb4007a4aa28024c1ac5077eb0840c877b7fd3a7afee0b48a9c218a54afc40a +-- hash: 2131bf1a367dd734cbccd900c4724c5b48e3f494501b2221e3f32ecaf0a12ec4 name: federator version: 1.0.0 @@ -41,15 +41,18 @@ library Federator.App Federator.Discovery Federator.Env + Federator.Error + Federator.Error.ServerError Federator.ExternalServer Federator.InternalServer + Federator.MockServer Federator.Monitor Federator.Monitor.Internal Federator.Options Federator.Remote + Federator.Response Federator.Run Federator.Service - Federator.Utils.PolysemyServerError Federator.Validation other-modules: Paths_federator @@ -58,12 +61,14 @@ library default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DerivingVia DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path build-depends: - HsOpenSSL - , HsOpenSSL-x509-system - , aeson + aeson + , async , base , bilge + , binary , bytestring + , bytestring-conversion + , constraints , containers , data-default , dns @@ -76,16 +81,13 @@ library , http-client , http-client-openssl , http-types - , http2-client - , http2-client-grpc + , http2 , imports , lens , metrics-core , metrics-wai , mtl - , mu-grpc-client - , mu-grpc-server - , mu-rpc + , network , network-uri , pem , polysemy @@ -93,18 +95,20 @@ library , retry , servant , servant-server + , streaming-commons , string-conversions , text + , time-manager , tinylog , tls , types-common , unix - , unliftio , uri-bytestring , uuid , wai , wai-utilities , warp + , warp-tls , wire-api , wire-api-federation , x509 @@ -122,12 +126,14 @@ executable federator default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DerivingVia DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path -threaded -with-rtsopts=-N1 -with-rtsopts=-T -rtsopts build-depends: - HsOpenSSL - , HsOpenSSL-x509-system - , aeson + aeson + , async , base , bilge + , binary , bytestring + , bytestring-conversion + , constraints , containers , data-default , dns @@ -141,16 +147,13 @@ executable federator , http-client , http-client-openssl , http-types - , http2-client - , http2-client-grpc + , http2 , imports , lens , metrics-core , metrics-wai , mtl - , mu-grpc-client - , mu-grpc-server - , mu-rpc + , network , network-uri , pem , polysemy @@ -158,18 +161,20 @@ executable federator , retry , servant , servant-server + , streaming-commons , string-conversions , text + , time-manager , tinylog , tls , types-common , unix - , unliftio , uri-bytestring , uuid , wai , wai-utilities , warp + , warp-tls , wire-api , wire-api-federation , x509 @@ -191,18 +196,22 @@ executable federator-integration default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DerivingVia DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path build-depends: - HsOpenSSL - , HsOpenSSL-x509-system - , aeson + aeson + , async , base , bilge + , binary , bytestring + , bytestring-conversion + , connection + , constraints , containers , cryptonite , data-default , dns , dns-util , either + , errors , exceptions , extended , federator @@ -211,17 +220,15 @@ executable federator-integration , hspec , http-client , http-client-openssl + , http-client-tls , http-types - , http2-client - , http2-client-grpc + , http2 , imports , lens , metrics-core , metrics-wai , mtl - , mu-grpc-client - , mu-grpc-server - , mu-rpc + , network , network-uri , optparse-applicative , pem @@ -231,20 +238,22 @@ executable federator-integration , retry , servant , servant-server + , streaming-commons , string-conversions , tasty , tasty-hunit , text + , time-manager , tinylog , tls , types-common , unix - , unliftio , uri-bytestring , uuid , wai , wai-utilities , warp + , warp-tls , wire-api , wire-api-federation , x509 @@ -258,11 +267,14 @@ test-suite federator-tests type: exitcode-stdio-1.0 main-is: Main.hs other-modules: + Test.Federator.Client Test.Federator.ExternalServer Test.Federator.InternalServer Test.Federator.Monitor Test.Federator.Options Test.Federator.Remote + Test.Federator.Response + Test.Federator.Util Test.Federator.Validation Paths_federator hs-source-dirs: @@ -270,12 +282,15 @@ test-suite federator-tests default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DerivingVia DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path -threaded -with-rtsopts=-N build-depends: - HsOpenSSL - , HsOpenSSL-x509-system + QuickCheck , aeson + , async , base , bilge + , binary , bytestring + , bytestring-conversion + , constraints , containers , data-default , directory @@ -290,17 +305,14 @@ test-suite federator-tests , http-client , http-client-openssl , http-types - , http2-client - , http2-client-grpc + , http2 , imports , interpolate , lens , metrics-core , metrics-wai , mtl - , mu-grpc-client - , mu-grpc-server - , mu-rpc + , network , network-uri , pem , polysemy @@ -308,6 +320,7 @@ test-suite federator-tests , polysemy-wire-zoo , retry , servant + , servant-client , servant-server , streaming-commons , string-conversions @@ -316,15 +329,16 @@ test-suite federator-tests , tasty-quickcheck , temporary , text + , time-manager , tinylog , tls , transformers , types-common , unix - , unliftio , uri-bytestring , uuid , wai + , wai-extra , wai-utilities , warp , warp-tls diff --git a/services/federator/federator.integration.yaml b/services/federator/federator.integration.yaml index 76077df2b84..8559f53624f 100644 --- a/services/federator/federator.integration.yaml +++ b/services/federator/federator.integration.yaml @@ -16,7 +16,7 @@ logNetStrings: false optSettings: # Filepath to one or more PEM-encoded server certificates to use as a trust - # store when making grpc requests to remote backends + # store when making requests to remote backends remoteCAStore: "test/resources/integration-ca.pem" # Would you like to federate with every wire-server installation ? diff --git a/services/federator/package.yaml b/services/federator/package.yaml index 8db0783a9d0..bb4c0b9655a 100644 --- a/services/federator/package.yaml +++ b/services/federator/package.yaml @@ -11,9 +11,13 @@ license: AGPL-3 extra-source-files: test/resources/**/* dependencies: - aeson +- async - base - bilge +- binary - bytestring +- bytestring-conversion +- constraints - containers - data-default - dns @@ -23,21 +27,16 @@ dependencies: - extended - filepath - hinotify -- HsOpenSSL -- HsOpenSSL-x509-system -- http2-client -- http2-client-grpc - http-client - http-client-openssl - http-types +- http2 - imports - lens - metrics-core - metrics-wai - mtl -- mu-grpc-client -- mu-grpc-server -- mu-rpc +- network - network-uri - pem - polysemy @@ -45,18 +44,20 @@ dependencies: - retry - servant - servant-server +- streaming-commons - string-conversions - text +- time-manager - tinylog - tls - types-common - unix -- unliftio - uri-bytestring - uuid - wai - wai-utilities - warp +- warp-tls - wire-api - wire-api-federation - x509 @@ -83,15 +84,18 @@ executables: main: Main.hs source-dirs: test/integration dependencies: + - connection + - cryptonite + - errors - federator - - tasty - - tasty-hunit - hspec - - random - - cryptonite + - http-client-tls - mtl - - retry - optparse-applicative + - random + - retry + - tasty + - tasty-hunit - types-common - yaml @@ -108,13 +112,16 @@ tests: - federator - interpolate - polysemy-mocks + - QuickCheck + - servant-client - streaming-commons - tasty - - tasty-quickcheck - tasty-hunit + - tasty-quickcheck - temporary - transformers - wai + - wai-extra - warp - warp-tls - yaml diff --git a/services/federator/src/Federator/App.hs b/services/federator/src/Federator/App.hs index eefd433e397..e1601ed8900 100644 --- a/services/federator/src/Federator/App.hs +++ b/services/federator/src/Federator/App.hs @@ -20,9 +20,8 @@ module Federator.App ( AppT, - Federator, runAppT, - liftAppIOToFederator, + embedApp, ) where @@ -33,7 +32,8 @@ import Control.Monad.Catch import Control.Monad.Except import Federator.Env (Env, applog, httpManager, requestId) import Imports -import Mu.Server (ServerError, ServerErrorIO) +import Polysemy +import Polysemy.Input import Servant.API.Generic () import Servant.Server () import System.Logger.Class as LC @@ -55,8 +55,6 @@ newtype AppT m a = AppT MonadReader Env ) -type Federator = AppT ServerErrorIO - instance MonadIO m => LC.MonadLogger (AppT m) where log l m = do g <- view applog @@ -75,12 +73,6 @@ instance MonadUnliftIO m => MonadUnliftIO (AppT m) where withRunInIO $ \runner -> inner (runner . flip runReaderT r . unAppT) -instance MonadError ServerError (AppT ServerErrorIO) where - throwError = lift . throwError @_ @ServerErrorIO - catchError a f = do - env <- ask - lift $ catchError (runAppT env a) (runAppT env . f) - instance MonadTrans AppT where lift = AppT . lift @@ -92,7 +84,7 @@ instance (Monad m, MonadIO m) => MonadHttp (AppT m) where runAppT :: forall m a. Env -> AppT m a -> m a runAppT e (AppT ma) = runReaderT ma e -liftAppIOToFederator :: AppT IO a -> Federator a -liftAppIOToFederator (AppT action) = do - env <- ask - lift . lift $ runReaderT action env +embedApp :: Members '[Embed m, Input Env] r => AppT m a -> Sem r a +embedApp (AppT action) = do + env <- input + embed $ runReaderT action env diff --git a/services/federator/src/Federator/Discovery.hs b/services/federator/src/Federator/Discovery.hs index 2123539ccab..096213f6760 100644 --- a/services/federator/src/Federator/Discovery.hs +++ b/services/federator/src/Federator/Discovery.hs @@ -21,8 +21,13 @@ import Data.Domain (Domain, domainText) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NonEmpty import Data.String.Conversions (cs) +import qualified Data.Text.Encoding as Text +import qualified Data.Text.Lazy as LText +import Federator.Error import Imports import qualified Network.DNS as DNS +import qualified Network.HTTP.Types as HTTP +import qualified Network.Wai.Utilities.Error as Wai import Polysemy import qualified Polysemy.Error as Polysemy import Polysemy.TinyLog (TinyLog) @@ -32,25 +37,39 @@ import Wire.Network.DNS.Effect (DNSLookup) import qualified Wire.Network.DNS.Effect as Lookup import Wire.Network.DNS.SRV (SrvEntry (srvTarget), SrvResponse (..), SrvTarget) -data LookupError - = LookupErrorSrvNotAvailable ByteString - | LookupErrorDNSError ByteString - deriving (Show, Eq) +data DiscoveryFailure + = DiscoveryFailureSrvNotAvailable ByteString + | DiscoveryFailureDNSError ByteString + deriving (Show, Eq, Typeable) + +instance Exception DiscoveryFailure + +instance AsWai DiscoveryFailure where + toWai e = Wai.mkError status label (LText.fromStrict (waiErrorDescription e)) + where + (status, label) = case e of + DiscoveryFailureSrvNotAvailable _ -> (HTTP.status422, "srv-record-not-found") + DiscoveryFailureDNSError _ -> (HTTP.status500, "discovery-failure") + waiErrorDescription :: DiscoveryFailure -> Text + waiErrorDescription (DiscoveryFailureSrvNotAvailable msg) = + "srv record not found: " <> Text.decodeUtf8 msg + waiErrorDescription (DiscoveryFailureDNSError msg) = + "DNS error: " <> Text.decodeUtf8 msg data DiscoverFederator m a where - DiscoverFederator :: Domain -> DiscoverFederator m (Either LookupError SrvTarget) - DiscoverAllFederators :: Domain -> DiscoverFederator m (Either LookupError (NonEmpty SrvTarget)) + DiscoverFederator :: Domain -> DiscoverFederator m (Either DiscoveryFailure SrvTarget) + DiscoverAllFederators :: Domain -> DiscoverFederator m (Either DiscoveryFailure (NonEmpty SrvTarget)) makeSem ''DiscoverFederator discoverFederatorWithError :: - Members '[DiscoverFederator, Polysemy.Error LookupError] r => + Members '[DiscoverFederator, Polysemy.Error DiscoveryFailure] r => Domain -> Sem r SrvTarget discoverFederatorWithError = Polysemy.fromEither <=< discoverFederator discoverAllFederatorsWithError :: - Members '[DiscoverFederator, Polysemy.Error LookupError] r => + Members '[DiscoverFederator, Polysemy.Error DiscoveryFailure] r => Domain -> Sem r (NonEmpty SrvTarget) discoverAllFederatorsWithError = Polysemy.fromEither <=< discoverAllFederators @@ -69,17 +88,17 @@ runFederatorDiscovery = interpret $ \case -- (https://wearezeta.atlassian.net/browse/SQCORE-912) domainSrv d = cs $ "_wire-server-federator._tcp." <> domainText d -lookupDomainByDNS :: Members '[DNSLookup, TinyLog] r => ByteString -> Sem r (Either LookupError (NonEmpty SrvTarget)) +lookupDomainByDNS :: Members '[DNSLookup, TinyLog] r => ByteString -> Sem r (Either DiscoveryFailure (NonEmpty SrvTarget)) lookupDomainByDNS domainSrv = do res <- Lookup.lookupSRV domainSrv case res of SrvAvailable entries -> pure $ Right $ srvTarget <$> entries SrvNotAvailable -> - pure $ Left $ LookupErrorSrvNotAvailable domainSrv + pure $ Left $ DiscoveryFailureSrvNotAvailable domainSrv SrvResponseError DNS.NameError -> -- Name error also means that the record is not available - pure $ Left $ LookupErrorSrvNotAvailable domainSrv + pure $ Left $ DiscoveryFailureSrvNotAvailable domainSrv SrvResponseError err -> do TinyLog.err $ Log.msg ("DNS Lookup failed" :: ByteString) . Log.field "error" (show err) - pure $ Left $ LookupErrorDNSError domainSrv + pure $ Left $ DiscoveryFailureDNSError domainSrv diff --git a/services/federator/src/Federator/Env.hs b/services/federator/src/Federator/Env.hs index b17a3b56591..4594b4fd852 100644 --- a/services/federator/src/Federator/Env.hs +++ b/services/federator/src/Federator/Env.hs @@ -31,7 +31,7 @@ import Network.DNS.Resolver (Resolver) import qualified Network.HTTP.Client as HTTP import qualified Network.TLS as TLS import qualified System.Logger.Class as LC -import Wire.API.Federation.GRPC.Types +import Wire.API.Federation.Component data TLSSettings = TLSSettings { _caStore :: CertificateStore, diff --git a/services/galley/src/Galley/Intra/Federator/Types.hs b/services/federator/src/Federator/Error.hs similarity index 59% rename from services/galley/src/Galley/Intra/Federator/Types.hs rename to services/federator/src/Federator/Error.hs index 7a316f7ce80..781c07bebfe 100644 --- a/services/galley/src/Galley/Intra/Federator/Types.hs +++ b/services/federator/src/Federator/Error.hs @@ -1,8 +1,6 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -- This file is part of the Wire Server implementation. -- --- Copyright (C) 2020 Wire Swiss GmbH +-- Copyright (C) 2021 Wire Swiss GmbH -- -- 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 @@ -17,12 +15,21 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.Intra.Federator.Types (FederatedRPC) where +module Federator.Error + ( AsWai (..), + errorResponse, + ) +where + +import qualified Data.Aeson as A +import Imports +import Network.HTTP.Types.Header +import qualified Network.Wai as Wai +import qualified Network.Wai.Utilities.Error as Wai -import Control.Monad.Except -import Galley.Monad -import Wire.API.Federation.Client -import Wire.API.Federation.GRPC.Types +class AsWai e where + toWai :: e -> Wai.Error + waiErrorDescription :: e -> Text -type FederatedRPC (c :: Component) = - FederatorClient c (ExceptT FederationClientFailure App) +errorResponse :: [Header] -> Wai.Error -> Wai.Response +errorResponse hdrs e = Wai.responseLBS (Wai.code e) hdrs (A.encode e) diff --git a/services/federator/src/Federator/Error/ServerError.hs b/services/federator/src/Federator/Error/ServerError.hs new file mode 100644 index 00000000000..798fe64272b --- /dev/null +++ b/services/federator/src/Federator/Error/ServerError.hs @@ -0,0 +1,45 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- 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 . + +module Federator.Error.ServerError where + +import qualified Data.Text.Lazy as LText +import Federator.Error +import Imports +import qualified Network.HTTP.Types as HTTP +import qualified Network.Wai.Utilities.Error as Wai +import Wire.API.Federation.Domain + +data ServerError + = InvalidRoute + | UnknownComponent Text + | NoOriginDomain + deriving (Eq, Show, Typeable) + +instance Exception ServerError + +instance AsWai ServerError where + toWai e@InvalidRoute = + Wai.mkError HTTP.status403 "invalid-endpoint" (LText.fromStrict (waiErrorDescription e)) + toWai e@(UnknownComponent _) = + Wai.mkError HTTP.status403 "unknown-component" (LText.fromStrict (waiErrorDescription e)) + toWai e@NoOriginDomain = + Wai.mkError HTTP.status403 "no-origin-domain" (LText.fromStrict (waiErrorDescription e)) + + waiErrorDescription InvalidRoute = "The requested endpoint does not exist" + waiErrorDescription (UnknownComponent name) = "No such component: " <> name + waiErrorDescription NoOriginDomain = "No " <> originDomainHeaderName <> " header" diff --git a/services/federator/src/Federator/ExternalServer.hs b/services/federator/src/Federator/ExternalServer.hs index 139904a1447..59546eb2165 100644 --- a/services/federator/src/Federator/ExternalServer.hs +++ b/services/federator/src/Federator/ExternalServer.hs @@ -1,7 +1,3 @@ -{-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE RecordWildCards #-} -{-# OPTIONS_GHC -Wno-partial-type-signatures #-} - -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2020 Wire Swiss GmbH @@ -19,125 +15,123 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Federator.ExternalServer where +module Federator.ExternalServer (callInward, serveInward, parseRequestData, RequestData (..)) where -import Control.Lens (view) -import Data.Aeson (decode) -import Data.ByteString.Char8 as B8 +import qualified Data.ByteString as BS +import Data.ByteString.Builder (toLazyByteString) import qualified Data.ByteString.Lazy as LBS -import Data.String.Conversions (cs) import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text -import Federator.App (Federator, runAppT) import Federator.Discovery -import Federator.Env (Env, applog, dnsResolver, runSettings) +import Federator.Env +import Federator.Error.ServerError import Federator.Options (RunSettings) -import Federator.Service (Service, interpretService, serviceCall) -import Federator.Utils.PolysemyServerError (absorbServerError) +import Federator.Response +import Federator.Service import Federator.Validation import Imports -import Mu.GRpc.Server (gRpcAppTrans, msgProtoBuf) -import Mu.Server (ServerError, ServerErrorIO, SingleServerT, singleService) -import qualified Mu.Server as Mu import qualified Network.HTTP.Types as HTTP import qualified Network.Wai as Wai -import qualified Network.Wai.Handler.Warp as Wai -import qualified Network.Wai.Utilities.Error as Wai import Polysemy -import qualified Polysemy.Error as Polysemy -import Polysemy.IO (embedToMonadIO) -import qualified Polysemy.Reader as Polysemy +import Polysemy.Error +import Polysemy.Input import Polysemy.TinyLog (TinyLog) import qualified Polysemy.TinyLog as Log import qualified System.Logger.Message as Log -import Wire.API.Federation.GRPC.Types -import Wire.Network.DNS.Effect as Polysemy - --- FUTUREWORK(federation): Versioning of the federation API. See --- https://higherkindness.io/mu-haskell/registry/ for some mu-haskell support --- for versioning schemas here. See https://wearezeta.atlassian.net/browse/SQCORE-883. +import Wire.API.Federation.Component +import Wire.API.Federation.Domain --- https://wearezeta.atlassian.net/wiki/spaces/CORE/pages/224166764/Limiting+access+to+federation+endpoints -callLocal :: - ( Members - '[ Service, - Embed IO, - TinyLog, - DiscoverFederator, - Polysemy.Reader RunSettings - ] - r - ) => - Maybe ByteString -> - Request -> - Sem r InwardResponse -callLocal mcert req@Request {..} = runInwardError $ do +-- FUTUREWORK(federation): Versioning of the federation API. +callInward :: + Members + '[ Service, + Embed IO, + TinyLog, + DiscoverFederator, + Error ValidationError, + Error DiscoveryFailure, + Error ServerError, + Input RunSettings + ] + r => + Wai.Request -> + Sem r Wai.Response +callInward wreq = do + req <- parseRequestData wreq Log.debug $ Log.msg ("Inward Request" :: ByteString) - . Log.field "request" (show req) + . Log.field "originDomain" (rdOriginDomain req) + . Log.field "component" (show (rdComponent req)) + . Log.field "rpc" (rdRPC req) - validatedDomain <- validateDomain mcert originDomain - validatedPath <- sanitizePath path - Log.debug $ - Log.msg ("Path validation" :: ByteString) - . Log.field "original path:" (show path) - . Log.field "sanitized result:" (show validatedPath) - (resStatus, resBody) <- serviceCall component validatedPath body validatedDomain + validatedDomain <- validateDomain (rdCertificate req) (rdOriginDomain req) + + let path = LBS.toStrict (toLazyByteString (HTTP.encodePathSegments ["federation", rdRPC req])) + + (status, body) <- serviceCall (rdComponent req) path (rdBody req) validatedDomain Log.debug $ Log.msg ("Inward Request response" :: ByteString) - . Log.field "resStatus" (show resStatus) - case HTTP.statusCode resStatus of - 200 -> pure $ maybe mempty LBS.toStrict resBody - 404 -> - case Wai.label <$> (decode =<< resBody) of - Just "no-endpoint" -> throwInward IInvalidEndpoint (cs $ "component " <> show component <> "does not have an endpoint " <> cs validatedPath) - _ -> throwInward IOther (cs $ show resStatus) - code -> do - let description = "Invalid HTTP status from component: " <> Text.pack (show code) <> " " <> Text.decodeUtf8 (HTTP.statusMessage resStatus) <> " Response body: " <> maybe mempty cs resBody - throwInward IOther description - where - runInwardError :: Sem (Polysemy.Error InwardError ': r) ByteString -> Sem r InwardResponse - runInwardError action = toResponse <$> Polysemy.runError action + . Log.field "status" (show status) - toResponse :: Either InwardError ByteString -> InwardResponse - toResponse (Left err) = InwardResponseError err - toResponse (Right bs) = InwardResponseBody bs + pure $ Wai.responseLBS status defaultHeaders (fromMaybe mempty body) -routeToInternal :: - (Members '[Service, Embed IO, Polysemy.Error ServerError, TinyLog, DiscoverFederator, Polysemy.Reader RunSettings] r) => - Maybe ByteString -> - SingleServerT info Inward (Sem r) _ -routeToInternal cert = singleService (Mu.method @"call" (callLocal cert)) +data RequestData = RequestData + { rdComponent :: Component, + rdRPC :: Text, + rdBody :: LByteString, + rdCertificate :: Maybe ByteString, + rdOriginDomain :: ByteString + } -lookupCertificate :: Wai.Request -> Maybe ByteString -lookupCertificate req = HTTP.urlDecode True <$> lookup "X-SSL-Certificate" (Wai.requestHeaders req) +-- path format: /federation// +-- inward service removes and forwards to component +-- where component = brig|galley|.. +-- Headers: +-- Wire-Origin-Domain +-- X-SSL-Certificate +-- +-- FUTUREWORK: use higher-level effects +parseRequestData :: + Members '[Error ServerError, Embed IO] r => + Wai.Request -> + Sem r RequestData +parseRequestData req = do + -- only POST is supported + when (Wai.requestMethod req /= HTTP.methodPost) $ + throw InvalidRoute + -- No query parameters are allowed + when (not . BS.null . Wai.rawQueryString $ req) $ + throw InvalidRoute + -- check that the path has the expected form + (componentSeg, rpcPath) <- case Wai.pathInfo req of + ["federation", comp, rpc] -> pure (comp, rpc) + _ -> throw InvalidRoute + + when (not (Text.all isAllowedRPCChar rpcPath)) $ + throw InvalidRoute + + when (Text.null rpcPath) $ + throw InvalidRoute + + -- get component, domain and body + component <- note (UnknownComponent componentSeg) $ parseComponent componentSeg + domain <- + note NoOriginDomain $ + lookup originDomainHeaderName (Wai.requestHeaders req) + body <- embed $ Wai.lazyRequestBody req + pure $ + RequestData + { rdComponent = component, + rdRPC = rpcPath, + rdBody = body, + rdCertificate = lookupCertificate req, + rdOriginDomain = domain + } + +isAllowedRPCChar :: Char -> Bool +isAllowedRPCChar c = isAsciiLower c || isAsciiUpper c || isNumber c || c == '_' || c == '-' serveInward :: Env -> Int -> IO () -serveInward env port = do - let app req = gRpcAppTrans msgProtoBuf transformer (routeToInternal (lookupCertificate req)) req - Wai.run port app - where - transformer :: - Sem - '[ DiscoverFederator, - DNSLookup, - TinyLog, - Embed IO, - Polysemy.Error ServerError, - Service, - Polysemy.Reader RunSettings, - Embed Federator - ] - a -> - ServerErrorIO a - transformer action = - runAppT env - . runM @Federator - . Polysemy.runReader (view runSettings env) - . interpretService - . absorbServerError - . embedToMonadIO @Federator - . Log.runTinyLog (view applog env) - . Polysemy.runDNSLookupWithResolver (view dnsResolver env) - . runFederatorDiscovery - $ action +serveInward = serve callInward + +lookupCertificate :: Wai.Request -> Maybe ByteString +lookupCertificate req = HTTP.urlDecode True <$> lookup "X-SSL-Certificate" (Wai.requestHeaders req) diff --git a/services/federator/src/Federator/InternalServer.hs b/services/federator/src/Federator/InternalServer.hs index ab1404bbc3b..a3fadf6f2ec 100644 --- a/services/federator/src/Federator/InternalServer.hs +++ b/services/federator/src/Federator/InternalServer.hs @@ -20,137 +20,112 @@ module Federator.InternalServer where +import Control.Exception (bracketOnError) +import qualified Control.Exception as E import Control.Lens (view) +import Data.Binary.Builder +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as C8 +import qualified Data.ByteString.Lazy as LBS +import Data.Default import Data.Domain (domainText) import Data.Either.Validation (Validation (..)) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import Data.X509.CertificateStore -import Federator.App (Federator, runAppT) -import Federator.Discovery (DiscoverFederator, LookupError (LookupErrorDNSError, LookupErrorSrvNotAvailable), runFederatorDiscovery) +import Federator.App (runAppT) +import Federator.Discovery (DiscoverFederator, DiscoveryFailure (DiscoveryFailureDNSError, DiscoveryFailureSrvNotAvailable), runFederatorDiscovery) import Federator.Env (Env, TLSSettings, applog, caStore, dnsResolver, runSettings, tls) +import Federator.Error.ServerError import Federator.Options (RunSettings) -import Federator.Remote (Remote, RemoteError (..), discoverAndCall, interpretRemote) -import Federator.Utils.PolysemyServerError (absorbServerError) +import Federator.Remote +import Federator.Response import Federator.Validation +import Foreign (mallocBytes) +import Foreign.Marshal (free) import Imports -import Mu.GRpc.Client.Record (GRpcReply (..)) -import Mu.GRpc.Server (msgProtoBuf, runGRpcAppTrans) -import Mu.Server (ServerError, ServerErrorIO, SingleServerT, singleService) -import qualified Mu.Server as Mu -import Network.HTTP2.Client.Exceptions (ClientError (..)) +import Network.HPACK (BufferSize) +import Network.HTTP.Client.Internal (openSocketConnection) +import Network.HTTP.Client.OpenSSL (withOpenSSL) +import qualified Network.HTTP.Types as HTTP +import qualified Network.HTTP2.Client as HTTP2 +import Network.Socket (Socket) +import qualified Network.Socket as NS import Network.TLS +import qualified Network.TLS as TLS +import qualified Network.TLS.Extra.Cipher as TLS +import qualified Network.Wai as Wai +import qualified Network.Wai.Handler.Warp as Warp import Polysemy +import Polysemy.Error import qualified Polysemy.Error as Polysemy import Polysemy.IO (embedToMonadIO) +import Polysemy.Input import qualified Polysemy.Input as Polysemy -import qualified Polysemy.Reader as Polysemy import qualified Polysemy.Resource as Polysemy import Polysemy.TinyLog (TinyLog) import qualified Polysemy.TinyLog as Log -import Wire.API.Federation.GRPC.Client (GrpcClientErr (..)) -import Wire.API.Federation.GRPC.Types +import qualified System.TimeManager as T +import qualified System.X509 as TLS +import Wire.API.Federation.Component import Wire.Network.DNS.Effect (DNSLookup) import qualified Wire.Network.DNS.Effect as Lookup import Wire.Network.DNS.SRV (SrvTarget (..)) -callOutward :: Members '[Remote, Polysemy.Reader RunSettings] r => FederatedRequest -> Sem r OutwardResponse -callOutward req = do - case validateFederatedRequest req of - Success vReq -> do - allowedRemote <- federateWith (vDomain vReq) - if allowedRemote - then mkRemoteResponse <$> discoverAndCall vReq - else pure $ mkOutwardErr FederationDeniedLocally ("federating with domain [" <> domainText (vDomain vReq) <> "] is not allowed (see federator configuration)") - Failure errs -> - pure $ mkOutwardErr InvalidRequest ("validation failed with: " <> Text.pack (show errs)) - --- FUTUREWORK(federation): Make these errors less stringly typed -mkRemoteResponse :: Either RemoteError (GRpcReply InwardResponse) -> OutwardResponse -mkRemoteResponse reply = - case reply of - Right (GRpcOk (InwardResponseBody res)) -> - OutwardResponseBody res - Right (GRpcOk (InwardResponseError err)) -> OutwardResponseInwardError err - Right (GRpcTooMuchConcurrency _) -> - mkOutwardErr TooMuchConcurrency "Too much concurrency" - Right (GRpcErrorCode code) -> - mkOutwardErr GrpcError ("code: " <> Text.pack (show code)) - Right (GRpcErrorString msg) -> - mkOutwardErr GrpcError (Text.pack msg) - Right (GRpcClientError EarlyEndOfStream) -> mkOutwardErr GrpcError "Early end of stream" - Left (RemoteErrorDiscoveryFailure domain err) -> - case err of - LookupErrorSrvNotAvailable _srvDomain -> - mkOutwardErr RemoteNotFound ("domain=" <> domainText domain) - LookupErrorDNSError dnsErr -> - mkOutwardErr DiscoveryFailed ("domain=" <> domainText domain <> " error=" <> Text.decodeUtf8 dnsErr) - Left (RemoteErrorClientFailure (SrvTarget host port) (GrpcClientErr reason)) -> - mkOutwardErr - GrpcError - (reason <> " target=" <> Text.decodeUtf8 host <> ":" <> Text.pack (show port)) - Left (RemoteErrorTLSException (SrvTarget host port) exc) -> - mkOutwardErr - TLSFailure - ( "Failed to establish TLS session with remote (target=" - <> Text.decodeUtf8 host - <> ":" - <> Text.pack (show port) - <> "): " - <> showTLSException exc - ) +data RequestData = RequestData + { rdTargetDomain :: Text, + rdComponent :: Component, + rdRPC :: Text, + rdHeaders :: [HTTP.Header], + rdBody :: LByteString + } -showTLSException :: TLSException -> Text -showTLSException (Terminated _ reason err) = Text.pack reason <> ": " <> showTLSError err -showTLSException (HandshakeFailed err) = Text.pack "handshake failed: " <> showTLSError err -showTLSException ConnectionNotEstablished = Text.pack "connection not established" +parseRequestData :: + Members '[Error ServerError, Embed IO] r => + Wai.Request -> + Sem r RequestData +parseRequestData req = do + -- only POST is supported + when (Wai.requestMethod req /= HTTP.methodPost) $ + throw InvalidRoute + -- No query parameters are allowed + when (not . BS.null . Wai.rawQueryString $ req) $ + throw InvalidRoute + -- check that the path has the expected form + (domain, componentSeg, rpcPath) <- case Wai.pathInfo req of + ["rpc", domain, comp, rpc] -> pure (domain, comp, rpc) + _ -> throw InvalidRoute + when (Text.null rpcPath) $ + throw InvalidRoute -showTLSError :: TLSError -> Text -showTLSError (Error_Misc msg) = Text.pack msg -showTLSError (Error_Protocol (msg, _, _)) = "protocol error: " <> Text.pack msg -showTLSError (Error_Certificate msg) = "certificate error: " <> Text.pack msg -showTLSError (Error_HandshakePolicy msg) = "handshake policy error: " <> Text.pack msg -showTLSError Error_EOF = "end-of-file error" -showTLSError (Error_Packet msg) = "packet error: " <> Text.pack msg -showTLSError (Error_Packet_unexpected actual expected) = - "unexpected packet: " <> Text.pack expected <> ", " <> "got " <> Text.pack actual -showTLSError (Error_Packet_Parsing msg) = "packet parsing error: " <> Text.pack msg + -- get component and body + component <- note (UnknownComponent componentSeg) $ parseComponent componentSeg + body <- embed $ Wai.lazyRequestBody req + pure $ + RequestData + { rdTargetDomain = domain, + rdComponent = component, + rdRPC = rpcPath, + rdHeaders = Wai.requestHeaders req, + rdBody = body + } -mkOutwardErr :: OutwardErrorType -> Text -> OutwardResponse -mkOutwardErr typ msg = OutwardResponseError $ OutwardError typ msg - -outward :: (Members '[Remote, Polysemy.Error ServerError, Polysemy.Reader RunSettings] r) => SingleServerT info Outward (Sem r) _ -outward = singleService (Mu.method @"call" callOutward) +callOutward :: + Members '[Remote, Embed IO, Error ValidationError, Error ServerError, Input RunSettings] r => + Wai.Request -> + Sem r Wai.Response +callOutward req = do + rd <- parseRequestData req + domain <- parseDomainText (rdTargetDomain rd) + ensureCanFederateWith domain + (status, result) <- + discoverAndCall + domain + (rdComponent rd) + (rdRPC rd) + (rdHeaders rd) + (fromLazyByteString (rdBody rd)) + pure $ Wai.responseBuilder status defaultHeaders result serveOutward :: Env -> Int -> IO () -serveOutward env port = do - runGRpcAppTrans msgProtoBuf port transformer outward - where - transformer :: - Sem - '[ Remote, - DiscoverFederator, - TinyLog, - DNSLookup, - Polysemy.Error ServerError, - Polysemy.Reader RunSettings, - Polysemy.Input TLSSettings, - Polysemy.Resource, - Embed IO, - Embed Federator - ] - a -> - ServerErrorIO a - transformer action = - runAppT env - . runM -- Embed Federator - . embedToMonadIO @Federator -- Embed IO - . Polysemy.runResource -- Resource - . Polysemy.runInputSem (embed @IO (readIORef (view tls env))) -- Input TLSSettings - . Polysemy.runReader (view runSettings env) -- Reader RunSettings - . absorbServerError - . Lookup.runDNSLookupWithResolver (view dnsResolver env) - . Log.runTinyLog (view applog env) - . runFederatorDiscovery - . interpretRemote - $ action +serveOutward = serve callOutward diff --git a/services/federator/src/Federator/MockServer.hs b/services/federator/src/Federator/MockServer.hs new file mode 100644 index 00000000000..ec28270ca9f --- /dev/null +++ b/services/federator/src/Federator/MockServer.hs @@ -0,0 +1,175 @@ +{-# LANGUAGE NumericUnderscores #-} +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- 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 . +{-# LANGUAGE RecordWildCards #-} + +module Federator.MockServer + ( MockTimeout (..), + MockException (..), + startMockServer, + withTempMockFederator, + FederatedRequest (..), + ) +where + +import qualified Control.Concurrent.Async as Async +import qualified Control.Exception as Exception +import Control.Exception.Base (throw) +import Control.Monad.Catch hiding (fromException) +import Data.Domain (Domain) +import Data.Streaming.Network (bindRandomPortTCP) +import qualified Data.Text.Lazy as LText +import Federator.Error +import Federator.Error.ServerError +import Federator.InternalServer +import Federator.Response +import Federator.Validation +import Imports hiding (fromException) +import Network.HTTP.Types as HTTP +import qualified Network.Wai as Wai +import qualified Network.Wai.Handler.Warp as Warp +import qualified Network.Wai.Handler.WarpTLS as Warp +import Network.Wai.Utilities.Error as Wai +import Polysemy +import Polysemy.Error hiding (throw) +import Polysemy.TinyLog +import System.Timeout (timeout) +import Wire.API.Federation.API (Component) +import Wire.API.Federation.Domain + +-- | Thrown in IO by mock federator if the server could not be started after 10 +-- seconds. +data MockTimeout = MockTimeout Warp.Port + deriving (Eq, Show, Typeable) + +instance Exception MockTimeout + +-- | This can be thrown by actions passed to mock federator to simulate +-- failures either in federator itself, or in the services it calls. +data MockException = MockErrorResponse HTTP.Status LText + deriving (Eq, Show, Typeable) + +instance AsWai MockException where + toWai (MockErrorResponse status message) = Wai.mkError status "mock-error" message + waiErrorDescription (MockErrorResponse _ message) = LText.toStrict message + +instance Exception MockException + +-- | Start a mock warp server on a random port, serving the given Wai application. +-- +-- If the 'Warp.TLSSettings` argument is provided, start an HTTPS server, +-- otherwise start a plain HTTP server. +-- +-- Returns an action to kill the spawned server, and the port on which the +-- server is running. +-- +-- This function should normally be used within 'bracket', e.g.: +-- @ +-- bracket (startMockServer Nothing app) fst $ \(close, port) -> +-- makeRequest "localhost" port +-- @ +startMockServer :: Maybe Warp.TLSSettings -> Wai.Application -> IO (IO (), Warp.Port) +startMockServer mtlsSettings app = do + (port, sock) <- bindRandomPortTCP "*6" + serverStarted <- newEmptyMVar + let wsettings = + Warp.defaultSettings + & Warp.setPort port + & Warp.setGracefulCloseTimeout2 0 -- Defaults to 2 seconds, causes server stop to take very long + & Warp.setBeforeMainLoop (putMVar serverStarted ()) + + serverThread <- Async.async $ case mtlsSettings of + Just tlsSettings -> Warp.runTLSSocket tlsSettings wsettings sock app + Nothing -> Warp.runSettingsSocket wsettings sock app + serverStartedSignal <- timeout 10_000_000 (readMVar serverStarted) + let close = do + me <- Async.poll serverThread + case me of + Nothing -> Async.cancel serverThread + Just (Left e) -> throw e + Just (Right a) -> pure a + case serverStartedSignal of + Nothing -> do + Async.cancel serverThread + throw (MockTimeout port) + Just _ -> pure (close, port) + +data FederatedRequest = FederatedRequest + { frOriginDomain :: Domain, + frTargetDomain :: Domain, + frComponent :: Component, + frRPC :: Text, + frBody :: LByteString + } + deriving (Eq, Show) + +-- | Spawn a mock federator on a random port and run an action while it is running. +-- +-- A mock federator is a web application that parses requests of the same form +-- as a regular outward service, but runs the provided action instead of +-- forwarding them to a remote federator. +withTempMockFederator :: + (MonadIO m, MonadMask m) => + [HTTP.Header] -> + (FederatedRequest -> IO LByteString) -> + (Warp.Port -> m a) -> + m (a, [FederatedRequest]) +withTempMockFederator headers resp action = do + remoteCalls <- newIORef [] + + let handleException :: SomeException -> MockException + handleException e = case Exception.fromException e of + Just mockE -> mockE + Nothing -> MockErrorResponse HTTP.status500 (LText.pack (displayException e)) + + let app request respond = do + response <- + runM + . discardLogs + . runWaiErrors + @'[ ValidationError, + ServerError, + MockException + ] + $ do + RequestData {..} <- parseRequestData request + domainText <- note NoOriginDomain $ lookup originDomainHeaderName rdHeaders + originDomain <- parseDomain domainText + targetDomain <- parseDomainText rdTargetDomain + let fedRequest = + ( FederatedRequest + { frOriginDomain = originDomain, + frTargetDomain = targetDomain, + frComponent = rdComponent, + frRPC = rdRPC, + frBody = rdBody + } + ) + embed @IO $ modifyIORef remoteCalls $ (<> [fedRequest]) + body <- + fromException @MockException + . handle (throw . handleException) + $ resp fedRequest + pure $ Wai.responseLBS HTTP.status200 headers body + respond response + result <- + bracket + (liftIO (startMockServer Nothing app)) + (liftIO . fst) + (\(_close, port) -> action port) + calls <- readIORef remoteCalls + pure (result, calls) diff --git a/services/federator/src/Federator/Remote.hs b/services/federator/src/Federator/Remote.hs index 5324529818b..bbf5146da53 100644 --- a/services/federator/src/Federator/Remote.hs +++ b/services/federator/src/Federator/Remote.hs @@ -18,53 +18,82 @@ -- with this program. If not, see . module Federator.Remote - ( Remote, + ( Remote (..), RemoteError (..), - discoverAndCall, interpretRemote, - mkGrpcClient, + discoverAndCall, blessedCiphers, ) where import Control.Lens ((^.)) -import Control.Monad.Except +import Data.Binary.Builder +import Data.ByteString.Conversion (toByteString') +import qualified Data.ByteString.Lazy as LBS import Data.Default (def) -import Data.Domain (Domain, domainText) -import Data.String.Conversions (cs) +import Data.Domain +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import qualified Data.Text.Encoding.Error as Text import qualified Data.X509 as X509 import qualified Data.X509.Validation as X509 import Federator.Discovery import Federator.Env (TLSSettings, caStore, creds) -import Federator.Options +import Federator.Error import Federator.Validation import Imports -import Mu.GRpc.Client.Optics (GRpcReply) -import Mu.GRpc.Client.Record (GRpcMessageProtocol (MsgProtoBuf)) -import Mu.GRpc.Client.TyApps (gRpcCall) -import Network.GRPC.Client.Helpers +import qualified Network.HTTP.Types as HTTP +import qualified Network.HTTP2.Client as HTTP2 import Network.TLS as TLS import qualified Network.TLS.Extra.Cipher as TLS import Polysemy -import qualified Polysemy.Error as Polysemy -import qualified Polysemy.Input as Polysemy -import qualified Polysemy.Reader as Polysemy -import qualified Polysemy.Resource as Polysemy -import Polysemy.TinyLog (TinyLog) -import qualified Polysemy.TinyLog as Log -import qualified System.Logger.Message as Log -import Wire.API.Federation.GRPC.Client -import Wire.API.Federation.GRPC.Types -import Wire.Network.DNS.SRV (SrvTarget (SrvTarget)) +import Polysemy.Error +import Polysemy.Input +import Wire.API.Federation.Client +import Wire.API.Federation.Component +import Wire.API.Federation.Error +import Wire.Network.DNS.SRV +-- | An error that can occur as a result of making a request to a remote +-- federator. data RemoteError - = RemoteErrorDiscoveryFailure Domain LookupError - | RemoteErrorClientFailure SrvTarget GrpcClientErr - | RemoteErrorTLSException SrvTarget TLSException - deriving (Show, Eq) + = -- | This means that an error occurred while trying to make a request to a + -- remote federator. + RemoteError SrvTarget FederatorClientHTTP2Error + | -- | This means that a request to a remote federator returned an error + -- response. The error response could be due to an error in the remote + -- federator itself, or in the services it proxied to. + RemoteErrorResponse SrvTarget HTTP.Status LByteString + deriving (Show) + +instance AsWai RemoteError where + toWai (RemoteError _ e) = federationRemoteHTTP2Error e + toWai (RemoteErrorResponse _ status _) = + federationRemoteResponseError status + + waiErrorDescription (RemoteError tgt e) = + "Error while connecting to " <> displayTarget tgt <> ": " + <> Text.pack (displayException e) + waiErrorDescription (RemoteErrorResponse tgt status body) = + "Federator at " <> displayTarget tgt <> " failed with status code " + <> Text.pack (show (HTTP.statusCode status)) + <> ": " + <> Text.decodeUtf8With Text.lenientDecode (LBS.toStrict body) + +displayTarget :: SrvTarget -> Text +displayTarget (SrvTarget hostname port) = + Text.decodeUtf8With Text.lenientDecode hostname + <> ":" + <> Text.pack (show port) data Remote m a where - DiscoverAndCall :: ValidatedFederatedRequest -> Remote m (Either RemoteError (GRpcReply InwardResponse)) + DiscoverAndCall :: + Domain -> + Component -> + Text -> + [HTTP.Header] -> + Builder -> + Remote m (HTTP.Status, Builder) makeSem ''Remote @@ -72,25 +101,53 @@ interpretRemote :: Members '[ Embed IO, DiscoverFederator, - TinyLog, - Polysemy.Reader RunSettings, - Polysemy.Input TLSSettings, - Polysemy.Resource + Error DiscoveryFailure, + Error RemoteError, + Input TLSSettings ] r => Sem (Remote ': r) a -> Sem r a interpretRemote = interpret $ \case - DiscoverAndCall ValidatedFederatedRequest {..} -> Polysemy.runError . logRemoteErrors $ do - target <- - Polysemy.mapError (RemoteErrorDiscoveryFailure vDomain) $ - discoverFederatorWithError vDomain - Polysemy.bracket (mkGrpcClient target) (embed @IO . closeGrpcClient) $ \client -> - callInward client vRequest + DiscoverAndCall domain component rpc headers body -> do + target@(SrvTarget hostname port) <- discoverFederatorWithError domain + settings <- input + let path = + LBS.toStrict . toLazyByteString $ + HTTP.encodePathSegments ["federation", componentName component, rpc] + req' = HTTP2.requestBuilder HTTP.methodPost path headers body + tlsConfig = mkTLSConfig settings hostname port + (status, _, result) <- + mapError (RemoteError target) . (fromEither =<<) . embed $ + performHTTP2Request (Just tlsConfig) req' hostname (fromIntegral port) + unless (HTTP.statusIsSuccessful status) $ + throw $ RemoteErrorResponse target status (toLazyByteString result) + pure (status, result) -callInward :: MonadIO m => GrpcClient -> Request -> m (GRpcReply InwardResponse) -callInward client request = - liftIO $ gRpcCall @'MsgProtoBuf @Inward @"Inward" @"call" client request +mkTLSConfig :: TLSSettings -> ByteString -> Word16 -> TLS.ClientParams +mkTLSConfig settings hostname port = + ( defaultParamsClient + (Text.unpack (Text.decodeUtf8With Text.lenientDecode hostname)) + (toByteString' port) + ) + { TLS.clientSupported = + def + { TLS.supportedCiphers = blessedCiphers, + -- FUTUREWORK: Figure out if we can drop TLS 1.2 + TLS.supportedVersions = [TLS.TLS12, TLS.TLS13] + }, + TLS.clientHooks = + def + { TLS.onServerCertificate = + X509.validate + X509.HashSHA256 + X509.defaultHooks {X509.hookValidateName = validateDomainName} + X509.defaultChecks {X509.checkLeafKeyPurpose = [X509.KeyUsagePurpose_ServerAuth]}, + TLS.onCertificateRequest = \_ -> pure (Just (settings ^. creds)), + TLS.onSuggestALPN = pure (Just ["h2"]) -- we only support HTTP2 + }, + TLS.clientShared = def {TLS.sharedCAStore = settings ^. caStore} + } -- FUTUREWORK: get review on blessed ciphers -- (https://wearezeta.atlassian.net/browse/SQCORE-910) @@ -109,72 +166,3 @@ blessedCiphers = TLS.cipher_ECDHE_ECDSA_CHACHA20POLY1305_SHA256, TLS.cipher_ECDHE_RSA_CHACHA20POLY1305_SHA256 ] - --- FUTUREWORK(federation): Consider using HsOpenSSL instead of tls for better --- security and to avoid having to depend on cryptonite and override validation --- hooks. This might involve forking http2-client: https://github.com/lucasdicioccio/http2-client/issues/76 --- FUTUREWORK(federation): Use openssl --- See also https://github.com/lucasdicioccio/http2-client/issues/76 --- FUTUREWORK(federation): Cache this client and use it for many requests (https://wearezeta.atlassian.net/browse/SQCORE-901) -mkGrpcClient :: - Members - '[ Embed IO, - Polysemy.Error RemoteError, - Polysemy.Input TLSSettings - ] - r => - SrvTarget -> - Sem r GrpcClient -mkGrpcClient target@(SrvTarget host port) = do - -- grpcClientConfigSimple using TLS is INSECURE and IGNORES any certificates - -- See https://github.com/haskell-grpc-native/http2-grpc-haskell/issues/47 - -- - let cfg = grpcClientConfigSimple (cs host) (fromInteger $ toInteger port) True - - settings <- Polysemy.input - - let tlsConfig = - (defaultParamsClient (cs host) (cs $ show port)) - { TLS.clientSupported = - def - { TLS.supportedCiphers = blessedCiphers, - -- FUTUREWORK: Figure out if we can drop TLS 1.2 - TLS.supportedVersions = [TLS.TLS12, TLS.TLS13] - }, - TLS.clientHooks = - def - { TLS.onServerCertificate = - X509.validate - X509.HashSHA256 - X509.defaultHooks {X509.hookValidateName = validateDomainName} - X509.defaultChecks {X509.checkLeafKeyPurpose = [X509.KeyUsagePurpose_ServerAuth]}, - TLS.onCertificateRequest = \_ -> pure (Just (settings ^. creds)) - }, - TLS.clientShared = def {TLS.sharedCAStore = settings ^. caStore} - } - let cfg' = cfg {_grpcClientConfigTLS = Just tlsConfig} - Polysemy.mapError (RemoteErrorClientFailure target) - . Polysemy.fromEither - =<< Polysemy.fromExceptionVia (RemoteErrorTLSException target) (createGrpcClient cfg') - -logRemoteErrors :: - Members '[Polysemy.Error RemoteError, TinyLog] r => - Sem r x -> - Sem r x -logRemoteErrors action = Polysemy.catch action $ \err -> do - Log.debug $ - Log.msg ("Failed to connect to remote federator" :: ByteString) - . addFields err - Polysemy.throw err - where - addFields (RemoteErrorDiscoveryFailure domain err) = - Log.field "domain" (domainText domain) - . Log.field "error" (show err) - addFields (RemoteErrorClientFailure (SrvTarget host port) err) = - Log.field "host" host - . Log.field "port" port - . Log.field "error" (show err) - addFields (RemoteErrorTLSException (SrvTarget host port) err) = - Log.field "host" host - . Log.field "port" port - . Log.field "error" (show err) diff --git a/services/federator/src/Federator/Response.hs b/services/federator/src/Federator/Response.hs new file mode 100644 index 00000000000..7edab1111b2 --- /dev/null +++ b/services/federator/src/Federator/Response.hs @@ -0,0 +1,136 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2020 Wire Swiss GmbH +-- +-- 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 . + +module Federator.Response + ( defaultHeaders, + serve, + runWaiError, + runWaiErrors, + ) +where + +import Control.Lens +import Federator.Discovery +import Federator.Env +import Federator.Error +import Federator.Error.ServerError +import Federator.Options +import Federator.Remote +import Federator.Service +import Federator.Validation +import Imports +import qualified Network.HTTP.Types as HTTP +import qualified Network.Wai as Wai +import qualified Network.Wai.Handler.Warp as Warp +import qualified Network.Wai.Utilities.Error as Wai +import qualified Network.Wai.Utilities.Server as Wai +import Polysemy +import Polysemy.Error +import Polysemy.Input +import Polysemy.Internal +import Polysemy.TinyLog +import Wire.Network.DNS.Effect + +defaultHeaders :: [HTTP.Header] +defaultHeaders = [("Content-Type", "application/json")] + +class ErrorEffects (ee :: [*]) r where + type Row ee :: EffectRow + runWaiErrors :: + Sem (Append (Row ee) r) Wai.Response -> + Sem r Wai.Response + +instance ErrorEffects '[] r where + type Row '[] = '[] + runWaiErrors = id + +instance + ( Member TinyLog (Append (Row ee) r), + AsWai e, + ErrorEffects ee r + ) => + ErrorEffects (e ': ee) r + where + type Row (e ': ee) = (Error e ': Row ee) + runWaiErrors = runWaiErrors @ee . runWaiError @e + +runWaiError :: + (AsWai e, Member TinyLog r) => + Sem (Error e ': r) Wai.Response -> + Sem r Wai.Response +runWaiError = + fmap (either (errorResponse defaultHeaders) id) + . runError + . flip catch logError + . mapError toWai + . raiseUnder + where + logError :: Members '[Error Wai.Error, TinyLog] r => Wai.Error -> Sem r a + logError e = do + err $ Wai.logErrorMsg Nothing e + throw e + +serve :: + (Wai.Request -> Sem AllEffects Wai.Response) -> + Env -> + Int -> + IO () +serve action env port = + Warp.run port + . Wai.catchErrors (view applog env) [] + $ app + where + app :: Wai.Application + app req respond = + runFederator env (action req) + >>= respond + +type AllEffects = + '[ Remote, + DiscoverFederator, + DNSLookup, -- needed by DiscoverFederator + Service, + Input RunSettings, + Input TLSSettings, -- needed by Remote + Input Env, -- needed by Service + Error ValidationError, + Error RemoteError, + Error ServerError, + Error DiscoveryFailure, + TinyLog, + Embed IO + ] + +-- | Run Sem action containing HTTP handlers. All errors have to been handled +-- already by this point. +runFederator :: Env -> Sem AllEffects Wai.Response -> IO Wai.Response +runFederator env = + runM @IO + . runTinyLog (view applog env) -- FUTUREWORK: add request id + . runWaiErrors + @'[ ValidationError, + RemoteError, + ServerError, + DiscoveryFailure + ] + . runInputConst env + . runInputSem (embed @IO (readIORef (view tls env))) + . runInputConst (view runSettings env) + . interpretService + . runDNSLookupWithResolver (view dnsResolver env) + . runFederatorDiscovery + . interpretRemote diff --git a/services/federator/src/Federator/Run.hs b/services/federator/src/Federator/Run.hs index bd0e786eee1..fafb6296714 100644 --- a/services/federator/src/Federator/Run.hs +++ b/services/federator/src/Federator/Run.hs @@ -35,6 +35,8 @@ module Federator.Run where import qualified Bilge as RPC +import Control.Concurrent.Async +import Control.Exception (bracket) import Control.Lens ((^.)) import Data.Default (def) import qualified Data.Metrics.Middleware as Metrics @@ -49,20 +51,14 @@ import qualified Network.DNS as DNS import qualified Network.HTTP.Client as HTTP import qualified System.Logger.Class as Log import qualified System.Logger.Extended as LogExt -import UnliftIO (bracket) -import UnliftIO.Async (async, waitAnyCancel) import Util.Options -import Wire.API.Federation.GRPC.Types +import Wire.API.Federation.Component import qualified Wire.Network.DNS.Helper as DNS ------------------------------------------------------------------------------ -- run/app -- FUTUREWORK(federation): Add metrics and status endpoints --- (this probably requires using HTTP. A Servant API could be used; and the --- internal grpc server converted to a WAI application, and the grpc application be --- "merged" using Servant's 'Raw' type (like in 'brig') with servant's http --- endpoints and exposed on the same port. See https://wearezeta.atlassian.net/browse/SQCORE-911. run :: Opts -> IO () run opts = do let resolvConf = mkResolvConf (optSettings opts) DNS.defaultResolvConf diff --git a/services/federator/src/Federator/Service.hs b/services/federator/src/Federator/Service.hs index 7428552c315..99b024fcc31 100644 --- a/services/federator/src/Federator/Service.hs +++ b/services/federator/src/Federator/Service.hs @@ -26,40 +26,45 @@ import Control.Lens (view) import Data.Domain import Data.String.Conversions (cs) import qualified Data.Text.Lazy as LText -import Federator.App (Federator, liftAppIOToFederator) -import Federator.Env (service) +import Federator.App +import Federator.Env import Imports import qualified Network.HTTP.Types as HTTP import Polysemy +import Polysemy.Input +import Wire.API.Federation.Component import Wire.API.Federation.Domain (originDomainHeaderName) -import Wire.API.Federation.GRPC.Types newtype ServiceError = ServiceErrorInvalidStatus HTTP.Status deriving (Eq, Show) data Service m a where -- | Returns status and body, 'HTTP.Response' is not nice to work with in tests - ServiceCall :: Component -> ByteString -> ByteString -> Domain -> Service m (HTTP.Status, Maybe LByteString) + ServiceCall :: Component -> ByteString -> LByteString -> Domain -> Service m (HTTP.Status, Maybe LByteString) makeSem ''Service -- FUTUREWORK(federation): Do we want to use servant client here? May make -- everything typed and safe -- --- FUTUREWORK: Avoid letting the IO errors escape into `Embed Federator` and +-- FUTUREWORK: Avoid letting the IO errors escape into `Embed IO` and -- return them as `Left` +-- +-- FUTUREWORK: unify this interpretation with similar ones in Galley +-- +-- FUTUREWORK: does it make sense to use a lower level abstraction instead of bilge here? interpretService :: - Member (Embed Federator) r => + Members '[Embed IO, Input Env] r => Sem (Service ': r) a -> Sem r a interpretService = interpret $ \case - ServiceCall component path body domain -> embed @Federator . liftAppIOToFederator $ do + ServiceCall component path body domain -> embedApp @IO $ do serviceReq <- view service <$> ask res <- rpc' (LText.pack (show component)) (serviceReq component) $ RPC.method HTTP.POST . RPC.path path - . RPC.body (RPC.RequestBodyBS body) + . RPC.body (RPC.RequestBodyLBS body) . RPC.contentJson . RPC.header originDomainHeaderName (cs (domainText domain)) pure (RPC.responseStatus res, RPC.responseBody res) diff --git a/services/federator/src/Federator/Utils/PolysemyServerError.hs b/services/federator/src/Federator/Utils/PolysemyServerError.hs deleted file mode 100644 index 820462ea442..00000000000 --- a/services/federator/src/Federator/Utils/PolysemyServerError.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-# OPTIONS_GHC -Wno-orphans #-} - --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2020 Wire Swiss GmbH --- --- 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 . - -module Federator.Utils.PolysemyServerError where - -import Control.Monad.Except (MonadError (..)) -import Federator.App (Federator) -import Imports -import Mu.Server (ServerError) -import Polysemy -import qualified Polysemy.Error as Polysemy - -instance Member (Polysemy.Error ServerError) r => MonadError ServerError (Sem r) where - throwError = Polysemy.throw - catchError = Polysemy.catch - -absorbServerError :: forall r a. (Member (Embed Federator) r) => Sem (Polysemy.Error ServerError ': r) a -> Sem r a -absorbServerError action = do - eitherResult <- Polysemy.runError action - case eitherResult of - Left err -> embed @Federator $ throwError err - Right res -> pure res diff --git a/services/federator/src/Federator/Validation.hs b/services/federator/src/Federator/Validation.hs index 27f135c960f..57a130a376f 100644 --- a/services/federator/src/Federator/Validation.hs +++ b/services/federator/src/Federator/Validation.hs @@ -16,51 +16,92 @@ -- with this program. If not, see . module Federator.Validation - ( federateWith, + ( ensureCanFederateWith, + parseDomain, + parseDomainText, validateDomain, - throwInward, - sanitizePath, validateDomainName, + ValidationError (..), ) where -import Data.Bifunctor (first) -import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as B8 -import Data.Domain (Domain, domainText, mkDomain) -import qualified Data.List.NonEmpty as NonEmpty +import Data.ByteString.Conversion +import Data.Domain +import Data.List.NonEmpty (NonEmpty) import qualified Data.PEM as X509 -import Data.String.Conversions (cs) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text +import qualified Data.Text.Encoding.Error as Text +import qualified Data.Text.Lazy as LText import qualified Data.X509 as X509 import qualified Data.X509.Validation as X509 import Federator.Discovery +import Federator.Error import Federator.Options import Imports -import Polysemy (Member, Members, Sem) -import qualified Polysemy.Error as Polysemy -import qualified Polysemy.Reader as Polysemy -import URI.ByteString -import Wire.API.Federation.GRPC.Types +import qualified Network.HTTP.Types as HTTP +import qualified Network.Wai.Utilities.Error as Wai +import Polysemy +import Polysemy.Error +import Polysemy.Input import Wire.Network.DNS.SRV (SrvTarget (..)) +data ValidationError + = NoClientCertificate + | CertificateParseError Text + | DomainParseError Text + | AuthenticationFailure (NonEmpty [X509.FailedReason]) + | FederationDenied Domain + deriving (Eq, Show, Typeable) + +instance Exception ValidationError + +instance AsWai ValidationError where + toWai err = + Wai.mkError HTTP.status403 (validationErrorLabel err) + . LText.fromStrict + $ waiErrorDescription err + + waiErrorDescription :: ValidationError -> Text + waiErrorDescription NoClientCertificate = "no client certificate provided" + waiErrorDescription (CertificateParseError reason) = + "certificate parse failure: " <> reason + waiErrorDescription (DomainParseError domain) = + "domain parse failure for [" <> domain <> "]" + waiErrorDescription (AuthenticationFailure errs) = + "none of the domain names match the certificate, errors: " + <> Text.pack (show (toList errs)) + waiErrorDescription (FederationDenied domain) = + "origin domain [" <> domainText domain <> "] not in the federation allow list" + +validationErrorLabel :: ValidationError -> LText +validationErrorLabel NoClientCertificate = "no-client-certificate" +validationErrorLabel (CertificateParseError _) = "certificate-parse-error" +validationErrorLabel (DomainParseError _) = "domain-parse-error" +validationErrorLabel (AuthenticationFailure _) = "authentication-failure" +validationErrorLabel (FederationDenied _) = "federation-denied" + -- | Validates an already-parsed domain against the allowList using the federator -- startup configuration. -federateWith :: Members '[Polysemy.Reader RunSettings] r => Domain -> Sem r Bool -federateWith targetDomain = do - strategy <- Polysemy.asks federationStrategy - pure $ case strategy of - AllowAll -> True - AllowList (AllowedDomains domains) -> targetDomain `elem` domains +ensureCanFederateWith :: + Members '[Input RunSettings, Error ValidationError] r => + Domain -> + Sem r () +ensureCanFederateWith targetDomain = do + strategy <- inputs federationStrategy + case strategy of + AllowAll -> pure () + AllowList (AllowedDomains domains) -> + unless (targetDomain `elem` domains) $ + throw (FederationDenied targetDomain) decodeCertificate :: - Member (Polysemy.Error InwardError) r => + Member (Error String) r => ByteString -> Sem r X509.Certificate decodeCertificate = - Polysemy.fromEither - . first (InwardError IAuthenticationFailed . Text.pack) + fromEither . ( (pure . X509.getCertificate) <=< X509.decodeSignedCertificate <=< (pure . X509.pemContent) @@ -73,96 +114,46 @@ decodeCertificate = expectOne _ [x] = pure x expectOne label _ = Left $ "found multiple " <> label <> "s" +parseDomain :: Member (Error ValidationError) r => ByteString -> Sem r Domain +parseDomain domain = + note (DomainParseError (Text.decodeUtf8With Text.lenientDecode domain)) $ + fromByteString domain + +parseDomainText :: Member (Error ValidationError) r => Text -> Sem r Domain +parseDomainText domain = + mapError @String (const (DomainParseError domain)) + . fromEither + . mkDomain + $ domain + -- | Validates an unknown domain string against the allowList using the -- federator startup configuration and checks that it matches the names reported -- by the client certificate validateDomain :: Members - '[ Polysemy.Reader RunSettings, - Polysemy.Error InwardError, + '[ Input RunSettings, + Error ValidationError, + Error DiscoveryFailure, DiscoverFederator ] r => Maybe ByteString -> - Text -> + ByteString -> Sem r Domain -validateDomain Nothing _ = throwInward IAuthenticationFailed "no client certificate provided" +validateDomain Nothing _ = throw NoClientCertificate validateDomain (Just encodedCertificate) unparsedDomain = do - targetDomain <- case mkDomain unparsedDomain of - Left parseErr -> throwInward IAuthenticationFailed (errDomainParsing parseErr) - Right d -> pure d + targetDomain <- parseDomain unparsedDomain -- run discovery to find the hostname of the client federator - certificate <- decodeCertificate encodedCertificate - hostnames <- - srvTargetDomain - <$$> Polysemy.mapError (InwardError IDiscoveryFailed . errDiscovery) (discoverAllFederatorsWithError targetDomain) + certificate <- + mapError (CertificateParseError . Text.pack) $ + decodeCertificate encodedCertificate + hostnames <- srvTargetDomain <$$> discoverAllFederatorsWithError targetDomain let validationErrors = (\h -> validateDomainName (B8.unpack h) certificate) <$> hostnames unless (any null validationErrors) $ - throwInward IAuthenticationFailed ("none of the domain names match the certificate, errrors: " <> (Text.pack . show . NonEmpty.toList $ validationErrors)) - - passAllowList <- federateWith targetDomain - if passAllowList - then pure targetDomain - else throwInward IFederationDeniedByRemote (errAllowList targetDomain) - where - errDomainParsing :: String -> Text - errDomainParsing err = "Domain parse failure for [" <> unparsedDomain <> "]: " <> cs err - - errAllowList :: Domain -> Text - errAllowList domain = "Origin domain [" <> domainText domain <> "] not in the federation allow list" - - errDiscovery :: LookupError -> Text - errDiscovery (LookupErrorSrvNotAvailable msg) = "srv record not found: " <> Text.decodeUtf8 msg - errDiscovery (LookupErrorDNSError msg) = "DNS error: " <> Text.decodeUtf8 msg - -throwInward :: Members '[Polysemy.Error InwardError] r => InwardErrorType -> Text -> Sem r a -throwInward errType errMsg = Polysemy.throw $ InwardError errType errMsg - --- | Normalize the path, and ensure the path begins with "federation/" after normalization -sanitizePath :: Members '[Polysemy.Error InwardError] r => ByteString -> Sem r ByteString -sanitizePath originalPath = do - when (BS.length originalPath > 200) $ - throwInward IForbiddenEndpoint "path too long" - -- we parse the path using the URI.ByteString module to make use of its normalization functions - uriRef <- case parseRelativeRef strictURIParserOptions originalPath of - Left err -> throwInward IForbiddenEndpoint (cs $ show err <> cs originalPath) - Right ref -> pure ref - - -- we don't expect any query parameters or other URL parts other than a plain path - when (queryPairs (rrQuery uriRef) /= []) $ - throwInward IForbiddenEndpoint "query parameters not allowed" - when (isJust (rrFragment uriRef)) $ - throwInward IForbiddenEndpoint "fragments not allowed" - when (isJust (rrAuthority uriRef)) $ - throwInward IForbiddenEndpoint "authority not allowed" - - -- Perform these normalizations: - -- - hTtP -> http - -- - eXaMpLe.org -> example.org - -- - If the scheme is known and the port is the default (e.g. 80 for http) it is removed. - -- - If the path is empty, set it to / - -- - Rewrite path from /foo//bar///baz to /foo/bar/baz - -- - Sorts parameters by parameter name - -- - Remove dot segments as per RFC3986 Section 5.2.4 - let normalizedURI = normalizeURIRef' aggressiveNormalization uriRef - -- sometimes normalization above results in a path with a leading slash. - -- For consistency, remove a leading slash, if any - let withoutLeadingSlash = BS.stripPrefix "/" normalizedURI - let normalized = fromMaybe normalizedURI withoutLeadingSlash - - -- to guard against double percent encoding, we disallow the '%' character - -- here, since we expect to only use POST requests on ASCII paths without any - -- query parameters - let (_, pTailEncoding) = BS.breakSubstring "%" normalized - unless (BS.null pTailEncoding) $ - throwInward IForbiddenEndpoint "percent encoding not allowed" - - -- Most importantly, only allow paths with the federation/ prefix. - unless ("federation/" `BS.isPrefixOf` normalized) $ - throwInward IForbiddenEndpoint ("disallowed path: " <> cs originalPath) + throw $ AuthenticationFailure validationErrors - pure normalized + ensureCanFederateWith targetDomain $> targetDomain -- | Match a hostname against the domain names of a certificate. -- diff --git a/services/federator/test/integration/Test/Federator/IngressSpec.hs b/services/federator/test/integration/Test/Federator/IngressSpec.hs index 2820598747b..04d80bb147d 100644 --- a/services/federator/test/integration/Test/Federator/IngressSpec.hs +++ b/services/federator/test/integration/Test/Federator/IngressSpec.hs @@ -17,43 +17,35 @@ module Test.Federator.IngressSpec where -import Bilge -import Control.Lens (view, (^.)) -import Control.Monad.Catch -import Data.Aeson -import qualified Data.ByteString.Lazy as LBS -import Data.Default (def) +import Control.Lens (view) +import qualified Data.Aeson as Aeson +import Data.Binary.Builder +import Data.Domain import Data.Handle import Data.LegalHold (UserLegalHoldStatus (UserLegalHoldNoConsent)) import Data.String.Conversions (cs) +import qualified Data.Text.Encoding as Text import qualified Data.X509 as X509 -import qualified Data.X509.Validation as X509 -import Federator.Env (caStore) -import Federator.Options -import Federator.Remote (RemoteError, blessedCiphers, mkGrpcClient) +import Federator.Discovery +import Federator.Env +import Federator.Remote import Imports -import Mu.GRpc.Client.TyApps -import Network.GRPC.Client.Helpers (_grpcClientConfigTLS) -import qualified Network.TLS as TLS -import qualified Polysemy -import qualified Polysemy.Error as Polysemy -import qualified Polysemy.Input as Polysemy -import qualified Polysemy.Reader as Polysemy -import Polysemy.TinyLog (discardLogs) +import qualified Network.HTTP.Types as HTTP +import Polysemy +import Polysemy.Error +import Polysemy.Input import Test.Federator.Util import Test.Hspec -import Test.Tasty.HUnit (assertFailure) import Util.Options (Endpoint (Endpoint)) -import Wire.API.Federation.GRPC.Client (closeGrpcClient, createGrpcClient) -import Wire.API.Federation.GRPC.Types hiding (body, path) -import qualified Wire.API.Federation.GRPC.Types as GRPC +import Wire.API.Federation.Component +import Wire.API.Federation.Domain import Wire.API.User import Wire.Network.DNS.SRV spec :: TestEnv -> Spec -spec env = +spec env = do describe "Ingress" $ do - it "should be accessible using grpc client and forward to the local brig" $ + it "should be accessible using http2 and forward to the local brig" $ runTestFederator env $ do brig <- view teBrig <$> ask user <- randomUser brig @@ -61,81 +53,74 @@ spec env = _ <- putHandle brig (userId user) hdl let expectedProfile = (publicProfile user UserLegalHoldNoConsent) {profileHandle = Just (Handle hdl)} - bdy <- asInwardBody =<< inwardBrigCallViaIngress "federation/get-user-by-handle" (encode hdl) - liftIO $ bdy `shouldBe` expectedProfile + (status, resp) <- + runTestSem + . assertNoError @RemoteError + $ inwardBrigCallViaIngress "get-user-by-handle" $ + (Aeson.fromEncoding (Aeson.toEncoding hdl)) + let actualProfile = Aeson.decode (toLazyByteString resp) + liftIO $ do + status `shouldBe` HTTP.status200 + actualProfile `shouldBe` (Just expectedProfile) - it "should not be accessible without a client certificate" $ - runTestFederator env $ do - brig <- view teBrig <$> ask - user <- randomUser brig - hdl <- randomHandle - _ <- putHandle brig (userId user) hdl + it "should not be accessible without a client certificate" $ + runTestFederator env $ do + brig <- view teBrig <$> ask + user <- randomUser brig + hdl <- randomHandle + _ <- putHandle brig (userId user) hdl + + -- Remove client certificate from settings + tlsSettings0 <- view teTLSSettings + let tlsSettings = + tlsSettings0 + { _creds = case _creds tlsSettings0 of + (_, privkey) -> (X509.CertificateChain [], privkey) + } + r <- + runTestSem + . runError @RemoteError + $ inwardBrigCallViaIngressWithSettings tlsSettings "get-user-by-handle" $ + (Aeson.fromEncoding (Aeson.toEncoding hdl)) + liftIO $ case r of + Right _ -> expectationFailure "Expected client certificate error, got response" + Left (RemoteError _ _) -> + expectationFailure "Expected client certificate error, got remote error" + Left (RemoteErrorResponse _ status _) -> status `shouldBe` HTTP.status400 + +runTestSem :: Sem '[Input TestEnv, Embed IO] a -> TestFederator IO a +runTestSem action = do + e <- ask + liftIO . runM . runInputConst e $ action - -- Create a client which has the right CA but not client certs - Endpoint ingressHost ingressPort <- cfgNginxIngress . view teTstOpts <$> ask - tlsSettings <- view teTLSSettings - let cfg = grpcClientConfigSimple (cs ingressHost) (fromInteger $ toInteger ingressPort) True - tlsConfig = - (TLS.defaultParamsClient (cs ingressHost) (cs $ show ingressPort)) - { TLS.clientSupported = - def - { TLS.supportedCiphers = blessedCiphers, - -- FUTUREWORK: Figure out if we can drop TLS 1.2 - TLS.supportedVersions = [TLS.TLS12, TLS.TLS13] - }, - TLS.clientShared = def {TLS.sharedCAStore = tlsSettings ^. caStore}, - TLS.clientHooks = - def - { TLS.onServerCertificate = - X509.validate X509.HashSHA256 X509.defaultHooks X509.defaultChecks - } - } - let cfg' = cfg {_grpcClientConfigTLS = Just tlsConfig} - Right client <- createGrpcClient cfg' - grpcReply <- inwardBrigCallViaIngressWithClient client "federation/get-user-by-handle" (encode hdl) - liftIO $ case grpcReply of - -- FUTUREWORK: Make it more obvious from nginx that this error is due - -- to mTLS failure. - GRpcErrorString err -> err `shouldBe` "GRPC status indicates failure: status-code=INTERNAL, status-message=\"HTTP Status 400\"" - _ -> assertFailure $ "Expect HTTP 400, got: " <> show grpcReply +discoverConst :: SrvTarget -> Sem (DiscoverFederator ': r) a -> Sem r a +discoverConst target = interpret $ \case + DiscoverFederator _ -> pure (Right target) + DiscoverAllFederators _ -> pure (Right (pure target)) inwardBrigCallViaIngress :: - ( MonadIO m, - MonadMask m, - MonadHttp m, - MonadReader TestEnv m, - HasCallStack - ) => - ByteString -> - LBS.ByteString -> - m (GRpcReply InwardResponse) -inwardBrigCallViaIngress requestPath payload = do - Endpoint ingressHost ingressPort <- cfgNginxIngress . view teTstOpts <$> ask - let target = SrvTarget (cs ingressHost) ingressPort - runSettings <- optSettings . view teOpts <$> ask - tlsSettings <- view teTLSSettings - bracket - ( liftIO - . Polysemy.runM - . Polysemy.runError @RemoteError - . discardLogs - . Polysemy.runInputConst tlsSettings - . Polysemy.runReader runSettings - $ mkGrpcClient target - ) - (either (const (pure ())) closeGrpcClient) - $ \case - Left clientErr -> liftIO $ assertFailure (show clientErr) - Right client -> inwardBrigCallViaIngressWithClient client requestPath payload + Members [Input TestEnv, Embed IO, Error RemoteError] r => + Text -> + Builder -> + Sem r (HTTP.Status, Builder) +inwardBrigCallViaIngress path payload = do + tlsSettings <- inputs (view teTLSSettings) + inwardBrigCallViaIngressWithSettings tlsSettings path payload -inwardBrigCallViaIngressWithClient :: (MonadIO m, MonadHttp m, MonadReader TestEnv m, HasCallStack) => GrpcClient -> ByteString -> LBS.ByteString -> m (GRpcReply InwardResponse) -inwardBrigCallViaIngressWithClient client requestPath payload = do - originDomain <- cfgOriginDomain <$> view teTstOpts - let brigCall = - GRPC.Request - { GRPC.component = Brig, - GRPC.path = requestPath, - GRPC.body = LBS.toStrict payload, - GRPC.originDomain = originDomain - } - liftIO $ gRpcCall @'MsgProtoBuf @Inward @"Inward" @"call" client brigCall +inwardBrigCallViaIngressWithSettings :: + Members [Input TestEnv, Embed IO, Error RemoteError] r => + TLSSettings -> + Text -> + Builder -> + Sem r (HTTP.Status, Builder) +inwardBrigCallViaIngressWithSettings tlsSettings requestPath payload = + do + Endpoint ingressHost ingressPort <- cfgNginxIngress . view teTstOpts <$> input + originDomain <- cfgOriginDomain . view teTstOpts <$> input + let target = SrvTarget (cs ingressHost) ingressPort + headers = [(originDomainHeaderName, Text.encodeUtf8 originDomain)] + runInputConst tlsSettings + . assertNoError @DiscoveryFailure + . discoverConst target + . interpretRemote + $ discoverAndCall (Domain "example.com") Brig requestPath headers payload diff --git a/services/federator/test/integration/Test/Federator/InwardSpec.hs b/services/federator/test/integration/Test/Federator/InwardSpec.hs index 8d285f47c7a..6216db63f96 100644 --- a/services/federator/test/integration/Test/Federator/InwardSpec.hs +++ b/services/federator/test/integration/Test/Federator/InwardSpec.hs @@ -18,26 +18,24 @@ module Test.Federator.InwardSpec where import Bilge +import Bilge.Assert import Control.Lens (view) import Data.Aeson import qualified Data.Aeson.Types as Aeson import qualified Data.ByteString as BS +import Data.ByteString.Conversion (toByteString') import qualified Data.ByteString.Lazy as LBS import Data.Handle import Data.LegalHold (UserLegalHoldStatus (UserLegalHoldNoConsent)) -import qualified Data.Text as Text +import Data.Text.Encoding import Federator.Options import Imports -import Mu.GRpc.Client.TyApps -import Network.GRPC.Client.Helpers import qualified Network.HTTP.Types as HTTP +import qualified Network.Wai.Utilities.Error as E import Test.Federator.Util import Test.Hspec -import Test.Tasty.HUnit (assertFailure) import Util.Options (Endpoint (Endpoint)) -import Wire.API.Federation.GRPC.Client -import Wire.API.Federation.GRPC.Types hiding (body, path) -import qualified Wire.API.Federation.GRPC.Types as GRPC +import Wire.API.Federation.Domain import Wire.API.User -- FUTUREWORK(federation): move these tests to brig-integration (benefit: avoid duplicating all of the brig helper code) @@ -46,7 +44,7 @@ import Wire.API.User -- -- +----------+ -- |federator-| +------+--+ --- |integration grpc |federator| +-- |integration http |federator| -- | |--------->+ + -- | | +----+----+ -- +----------+ | @@ -69,93 +67,75 @@ spec env = _ <- putHandle brig (userId user) hdl let expectedProfile = (publicProfile user UserLegalHoldNoConsent) {profileHandle = Just (Handle hdl)} - bdy <- asInwardBody =<< inwardBrigCall "federation/get-user-by-handle" (encode hdl) + bdy <- + responseJsonError =<< inwardCall "/federation/brig/get-user-by-handle" (encode hdl) + inwardBrigCall "http://localhost:8080/i/users" (encode o) - expectErr IForbiddenEndpoint err + inwardCall "/federation/brig/../i/users" (encode o) + !!! const 403 === statusCode it "should only accept /federation/ paths" $ runTestFederator env $ do let o = object ["name" .= ("fakeNewUser" :: Text)] - err <- asInwardErrorUnsafe <$> inwardBrigCall "i/users" (encode o) - expectErr IForbiddenEndpoint err - - it "should only accept /federation/ paths (also when there are /../ segments)" $ - runTestFederator env $ do - let o = object ["name" .= ("fakeNewUser" :: Text)] - err <- asInwardErrorUnsafe <$> inwardBrigCall "federation/../i/users" (encode o) - expectErr IForbiddenEndpoint err + inwardCall "/i/users" (encode o) + !!! const 403 === statusCode -- Matching client certificates against domain names is better tested in -- unit tests. it "should reject requests without a client certificate" $ runTestFederator env $ do - brig <- view teBrig <$> ask - user <- randomUser brig + originDomain <- cfgOriginDomain <$> view teTstOpts hdl <- randomHandle - _ <- putHandle brig (userId user) hdl - - client <- viewFederatorExternalClientWithoutCert - err <- asInwardError =<< inwardBrigCallWithClient client "federation/get-user-by-handle" (encode hdl) - expectErr IAuthenticationFailed err - --- Utility functions --- -expectErr :: InwardErrorType -> InwardError -> TestFederator IO () -expectErr expectedType err = - unless (inwardErrorType err == expectedType) - . liftIO - $ assertFailure $ "expected type '" <> show expectedType <> "' but got " <> show err - -inwardBrigCall :: (MonadIO m, MonadHttp m, MonadReader TestEnv m, HasCallStack) => ByteString -> LBS.ByteString -> m (GRpcReply InwardResponse) -inwardBrigCall requestPath payload = do - c <- viewFederatorExternalClient - inwardBrigCallWithClient c requestPath payload - -inwardBrigCallWithClient :: (MonadIO m, MonadHttp m, MonadReader TestEnv m, HasCallStack) => GrpcClient -> ByteString -> LBS.ByteString -> m (GRpcReply InwardResponse) -inwardBrigCallWithClient c requestPath payload = do - originDomain <- cfgOriginDomain <$> view teTstOpts - let brigCall = - GRPC.Request - { GRPC.component = Brig, - GRPC.path = requestPath, - GRPC.body = LBS.toStrict payload, - GRPC.originDomain = originDomain - } - liftIO $ gRpcCall @'MsgProtoBuf @Inward @"Inward" @"call" c brigCall - -viewFederatorExternalClient :: (MonadIO m, MonadHttp m, MonadReader TestEnv m, HasCallStack) => m GrpcClient -viewFederatorExternalClient = do + inwardCallWithHeaders + "federation/brig/get-user-by-handle" + [(originDomainHeaderName, toByteString' originDomain)] + (encode hdl) + !!! const 403 === statusCode + +inwardCallWithHeaders :: + (MonadIO m, MonadHttp m, MonadReader TestEnv m, HasCallStack) => + ByteString -> + [HTTP.Header] -> + LBS.ByteString -> + m (Response (Maybe LByteString)) +inwardCallWithHeaders requestPath hh payload = do Endpoint fedHost fedPort <- cfgFederatorExternal <$> view teTstOpts - exampleCert <- liftIO . BS.readFile . clientCertificate . optSettings =<< view teOpts - let cfg = - (grpcClientConfigSimple (Text.unpack fedHost) (fromIntegral fedPort) False) - { _grpcClientConfigHeaders = [("X-SSL-Certificate", HTTP.urlEncode True exampleCert)] - } - client <- createGrpcClient cfg - case client of - Left clientErr -> liftIO $ assertFailure (show clientErr) - Right cli -> pure cli - -viewFederatorExternalClientWithoutCert :: (MonadIO m, MonadHttp m, MonadReader TestEnv m, HasCallStack) => m GrpcClient -viewFederatorExternalClientWithoutCert = do + post + ( host (encodeUtf8 fedHost) + . port fedPort + . path requestPath + . foldr (uncurry (\k v r -> header k v . r)) id hh + . bytes (toByteString' payload) + ) + +inwardCall :: + (MonadIO m, MonadHttp m, MonadReader TestEnv m, HasCallStack) => + ByteString -> + LBS.ByteString -> + m (Response (Maybe LByteString)) +inwardCall requestPath payload = do Endpoint fedHost fedPort <- cfgFederatorExternal <$> view teTstOpts - let cfg = grpcClientConfigSimple (Text.unpack fedHost) (fromIntegral fedPort) False - client <- createGrpcClient cfg - case client of - Left clientErr -> liftIO $ assertFailure (show clientErr) - Right cli -> pure cli - -viewIngress :: (MonadReader TestEnv m, HasCallStack) => m Endpoint -viewIngress = cfgNginxIngress . view teTstOpts <$> ask + originDomain <- cfgOriginDomain <$> view teTstOpts + clientCertFilename <- clientCertificate . optSettings . view teOpts <$> ask + clientCert <- liftIO $ BS.readFile clientCertFilename + post + ( host (encodeUtf8 fedHost) + . port fedPort + . path requestPath + . header "X-SSL-Certificate" (HTTP.urlEncode True clientCert) + . header originDomainHeaderName (toByteString' originDomain) + . bytes (toByteString' payload) + ) diff --git a/services/federator/test/integration/Test/Federator/Util.hs b/services/federator/test/integration/Test/Federator/Util.hs index e80da9dd1ef..90c97df1b97 100644 --- a/services/federator/test/integration/Test/Federator/Util.hs +++ b/services/federator/test/integration/Test/Federator/Util.hs @@ -32,28 +32,27 @@ import Crypto.Random.Types (MonadRandom, getRandomBytes) import Data.Aeson import Data.Aeson.TH import qualified Data.Aeson.Types as Aeson -import Data.Bifunctor (first) import qualified Data.ByteString.Char8 as C8 -import Data.Data (typeRep) import Data.Id import Data.Misc -import Data.Proxy import Data.String.Conversions import qualified Data.Text as Text import qualified Data.UUID as UUID import qualified Data.UUID.V4 as UUID import qualified Data.Yaml as Yaml -import Federator.Env (TLSSettings (..)) +import Federator.Env import Federator.Options -import Federator.Run (mkTLSSettingsOrThrow) +import Federator.Run import Imports -import Mu.GRpc.Client.TyApps +import qualified Network.Connection +import Network.HTTP.Client.TLS import qualified Options.Applicative as OPA +import Polysemy +import Polysemy.Error import System.Random import Test.Federator.JSON import Test.Tasty.HUnit import Util.Options -import Wire.API.Federation.GRPC.Types (InwardError, InwardResponse (..)) import Wire.API.User import Wire.API.User.Auth @@ -143,7 +142,8 @@ cliOptsParser = -- | Create an environment for integration tests from integration and federator config files. mkEnv :: HasCallStack => IntegrationConfig -> Opts -> IO TestEnv mkEnv _teTstOpts _teOpts = do - _teMgr :: Manager <- newManager defaultManagerSettings + let managerSettings = mkManagerSettings (Network.Connection.TLSSettingsSimple True False False) Nothing + _teMgr :: Manager <- newManager managerSettings let _teBrig = endpointToReq (cfgBrig _teTstOpts) _teTLSSettings <- mkTLSSettingsOrThrow (optSettings _teOpts) pure TestEnv {..} @@ -154,39 +154,6 @@ destroyEnv _ = pure () endpointToReq :: Endpoint -> (Bilge.Request -> Bilge.Request) endpointToReq ep = Bilge.host (ep ^. epHost . to cs) . Bilge.port (ep ^. epPort) --- grpc utilities - -asInwardBody :: forall a. (HasCallStack, Typeable a, FromJSON a) => GRpcReply InwardResponse -> TestFederator IO a -asInwardBody = either (liftIO . assertFailure) pure . asInwardBodyEither - -asInwardBodyUnsafe :: (HasCallStack, Typeable a, FromJSON a) => GRpcReply InwardResponse -> a -asInwardBodyUnsafe = either err id . asInwardBodyEither - where - err parserErr = error . unwords $ ["asInwardBodyUnsafe:"] <> [parserErr] - -asInwardBodyEither :: forall a. (HasCallStack, Typeable a, FromJSON a) => GRpcReply InwardResponse -> Either String a -asInwardBodyEither (GRpcOk (InwardResponseError err)) = Left (show err) -asInwardBodyEither (GRpcOk (InwardResponseBody bdy)) = first addTypeInfo $ eitherDecodeStrict bdy - where - addTypeInfo :: String -> String - addTypeInfo = (("Could not parse InwardResponseBody as '" <> show (typeRep (Proxy @a)) <> "': ") <>) -asInwardBodyEither other = Left $ "GRpc call failed unexpectedly: " <> show other - -asInwardError :: HasCallStack => GRpcReply InwardResponse -> TestFederator IO InwardError -asInwardError = either err pure . asInwardErrorEither - where - err parserErr = liftIO $ assertFailure (unwords $ ["asInwardError:"] <> [parserErr]) - -asInwardErrorUnsafe :: HasCallStack => GRpcReply InwardResponse -> InwardError -asInwardErrorUnsafe = either err id . asInwardErrorEither - where - err parserErr = error . unwords $ ["asInwardErrorUnsafe:"] <> [parserErr] - -asInwardErrorEither :: HasCallStack => GRpcReply InwardResponse -> Either String InwardError -asInwardErrorEither (GRpcOk (InwardResponseError err)) = Right err -asInwardErrorEither (GRpcOk (InwardResponseBody bdy)) = Left ("expected InwardError, but got InwardResponseBody: " <> show bdy) -asInwardErrorEither other = Left $ "GRpc call failed unexpectedly: " <> show other - -- All the code below is copied from brig-integration tests -- FUTUREWORK: This should live in another package and shared by all the integration tests @@ -363,3 +330,9 @@ randomHandle :: MonadIO m => m Text randomHandle = liftIO $ do nrs <- replicateM 21 (randomRIO (97, 122)) -- a-z return (Text.pack (map chr nrs)) + +assertNoError :: (Show e, Member (Embed IO) r) => Sem (Error e ': r) x -> Sem r x +assertNoError = + runError >=> \case + Left err -> embed @IO . assertFailure $ "Unexpected error: " <> show err + Right x -> pure x diff --git a/services/federator/test/unit/Main.hs b/services/federator/test/unit/Main.hs index 7cd09476a6c..c3c54a42d1a 100644 --- a/services/federator/test/unit/Main.hs +++ b/services/federator/test/unit/Main.hs @@ -21,12 +21,14 @@ module Main where import Imports +import qualified Test.Federator.Client import qualified Test.Federator.ExternalServer import qualified Test.Federator.InternalServer import qualified Test.Federator.Monitor import qualified Test.Federator.Options import qualified Test.Federator.Remote -import qualified Test.Federator.Validation as Validation +import qualified Test.Federator.Response +import qualified Test.Federator.Validation import Test.Tasty main :: IO () @@ -35,9 +37,11 @@ main = testGroup "Tests" [ Test.Federator.Options.tests, - Validation.tests, + Test.Federator.Validation.tests, + Test.Federator.Client.tests, Test.Federator.InternalServer.tests, Test.Federator.ExternalServer.tests, Test.Federator.Monitor.tests, - Test.Federator.Remote.tests + Test.Federator.Remote.tests, + Test.Federator.Response.tests ] diff --git a/services/federator/test/unit/Test/Federator/Client.hs b/services/federator/test/unit/Test/Federator/Client.hs new file mode 100644 index 00000000000..a0d172050f9 --- /dev/null +++ b/services/federator/test/unit/Test/Federator/Client.hs @@ -0,0 +1,186 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- 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 . + +module Test.Federator.Client (tests) where + +import Control.Exception hiding (handle) +import qualified Data.Aeson as Aeson +import Data.Bifunctor (first) +import Data.Domain +import Federator.MockServer +import Imports +import Network.HTTP.Types as HTTP +import qualified Network.HTTP2.Client as HTTP2 +import Network.Wai.Utilities.Error as Wai +import Test.QuickCheck (arbitrary, generate) +import Test.Tasty +import Test.Tasty.HUnit +import Util.Options +import Wire.API.Federation.API +import Wire.API.Federation.API.Brig +import Wire.API.Federation.Client +import Wire.API.Federation.Component +import Wire.API.Federation.Error +import Wire.API.User (UserProfile) + +targetDomain :: Domain +targetDomain = Domain "target.example.com" + +originDomain :: Domain +originDomain = Domain "origin.example.com" + +defaultHeaders :: [HTTP.Header] +defaultHeaders = [("Content-Type", "application/json")] + +tests :: TestTree +tests = + testGroup + "Federator.Client" + [ testGroup + "Servant" + [ testCase "testClientSuccess" testClientSuccess, + testCase "testClientFailure" testClientFailure, + testCase "testFederatorFailure" testFederatorFailure, + testCase "testClientException" testClientExceptions, + testCase "testClientConnectionError" testClientConnectionError + ], + testGroup + "HTTP2 client" + [ testCase "testResponseHeaders" testResponseHeaders + ] + ] + +newtype ResponseFailure = ResponseFailure Wai.Error + deriving (Show) + +withMockFederatorClient :: + KnownComponent c => + [HTTP.Header] -> + (FederatedRequest -> IO LByteString) -> + FederatorClient c a -> + IO (Either ResponseFailure a, [FederatedRequest]) +withMockFederatorClient headers resp action = withTempMockFederator headers resp $ \port -> do + let env = + FederatorClientEnv + { ceOriginDomain = originDomain, + ceTargetDomain = targetDomain, + ceFederator = Endpoint "127.0.0.1" (fromIntegral port) + } + a <- runFederatorClient env action + case a of + Left (FederatorClientError r) -> pure (Left (ResponseFailure r)) + Left err -> assertFailure $ "Unexpected client error: " <> displayException err + Right x -> pure (Right x) + +testClientSuccess :: IO () +testClientSuccess = do + handle <- generate arbitrary + expectedResponse :: UserProfile <- generate arbitrary + + (actualResponse, sentRequests) <- + withMockFederatorClient defaultHeaders (const (pure (Aeson.encode (Just expectedResponse)))) $ + getUserByHandle clientRoutes handle + + sentRequests + @?= [ FederatedRequest + { frTargetDomain = targetDomain, + frBody = Aeson.encode handle, + frOriginDomain = originDomain, + frRPC = "get-user-by-handle", + frComponent = Brig + } + ] + first (const ()) actualResponse @?= Right (Just expectedResponse) + +testClientFailure :: IO () +testClientFailure = do + handle <- generate arbitrary + + (actualResponse, _) <- + withMockFederatorClient + defaultHeaders + (const (throw (MockErrorResponse HTTP.status422 "wrong domain"))) + $ do + getUserByHandle clientRoutes handle + + case actualResponse of + Right _ -> assertFailure "unexpected success" + Left (ResponseFailure werr) -> do + Wai.code werr @?= HTTP.status422 + Wai.message werr @?= "wrong domain" + +testFederatorFailure :: IO () +testFederatorFailure = do + handle <- generate arbitrary + + (actualResponse, _) <- + withMockFederatorClient + defaultHeaders + (const (throw (MockErrorResponse HTTP.status403 "invalid path"))) + $ do + getUserByHandle clientRoutes handle + + case actualResponse of + Right _ -> assertFailure "unexpected success" + Left (ResponseFailure werr) -> do + Wai.code werr @?= HTTP.status500 + Wai.label werr @?= "federation-local-error" + +testClientExceptions :: IO () +testClientExceptions = do + handle <- generate arbitrary + + (response, _) <- + withMockFederatorClient defaultHeaders (const (evaluate (error "unhandled exception"))) $ + getUserByHandle clientRoutes handle + + case response of + Right _ -> assertFailure "unexpected success" + Left (ResponseFailure werr) -> Wai.code werr @?= HTTP.status500 + +testClientConnectionError :: IO () +testClientConnectionError = do + handle <- generate arbitrary + let env = + FederatorClientEnv + { ceOriginDomain = originDomain, + ceTargetDomain = targetDomain, + ceFederator = Endpoint "127.0.0.1" 1 + } + result <- runFederatorClient env (getUserByHandle clientRoutes handle) + case result of + Left (FederatorClientHTTP2Error (FederatorClientConnectionError _)) -> pure () + Left x -> assertFailure $ "Expected connection error, got: " <> show x + Right _ -> assertFailure "Expected connection with the server to fail" + +testResponseHeaders :: IO () +testResponseHeaders = do + (r, _) <- withTempMockFederator [("X-Foo", "bar")] (const mempty) $ \port -> do + let req = + HTTP2.requestBuilder + HTTP.methodPost + "/rpc/target.example.com/brig/test" + [("Wire-Origin-Domain", "origin.example.com")] + "body" + performHTTP2Request Nothing req "127.0.0.1" port + case r of + Left err -> + assertFailure $ + "Unexpected error while connecting to mock federator: " <> show err + Right (status, headers, _) -> do + status @?= HTTP.status200 + lookup "X-Foo" headers @?= Just "bar" diff --git a/services/federator/test/unit/Test/Federator/ExternalServer.hs b/services/federator/test/unit/Test/Federator/ExternalServer.hs index 1ced5c1083b..a1c749cec4a 100644 --- a/services/federator/test/unit/Test/Federator/ExternalServer.hs +++ b/services/federator/test/unit/Test/Federator/ExternalServer.hs @@ -1,5 +1,3 @@ -{-# OPTIONS_GHC -Wno-orphans #-} - -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2020 Wire Swiss GmbH @@ -16,97 +14,304 @@ -- -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . +{-# OPTIONS_GHC -Wno-orphans #-} module Test.Federator.ExternalServer where import qualified Data.ByteString as BS +import Data.Default import Data.Domain import Data.String.Conversions (cs) -import Federator.ExternalServer (callLocal) +import qualified Data.Text.Encoding as Text +import Federator.Discovery +import Federator.Error.ServerError (ServerError (..)) +import Federator.ExternalServer import Federator.Service (Service) +import Federator.Validation import Imports import qualified Network.HTTP.Types as HTTP -import Polysemy (embed, runM) -import qualified Polysemy.Reader as Polysemy +import qualified Network.Wai as Wai +import qualified Network.Wai.Utilities.Server as Wai +import Polysemy +import Polysemy.Error +import Polysemy.Input import qualified Polysemy.TinyLog as TinyLog import Test.Federator.Options (noClientCertSettings) +import Test.Federator.Util import Test.Federator.Validation (mockDiscoveryTrivial) import Test.Polysemy.Mock (Mock (mock), evalMock) import Test.Polysemy.Mock.TH (genMock) -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (assertEqual, assertFailure, testCase) -import Wire.API.Federation.GRPC.Types -import qualified Wire.API.Federation.GRPC.Types as InwardError +import Test.Tasty +import Test.Tasty.HUnit +import Wire.API.Federation.Component genMock ''Service tests :: TestTree tests = - testGroup "ExternalServer" $ + testGroup + "ExternalServer" [ requestBrigSuccess, requestBrigFailure, - requestGalleySuccess + requestGalleySuccess, + requestNoCertificate, + requestNoDomain, + testInvalidPaths, + testInvalidComponent, + testMethod ] +exampleRequest :: FilePath -> ByteString -> IO Wai.Request +exampleRequest certFile path = do + cert <- BS.readFile certFile + testRequest + def + { trPath = path, + trDomainHeader = Just (Text.encodeUtf8 exampleDomain), + trCertificateHeader = Just cert, + trBody = "\"foo\"" + } + requestBrigSuccess :: TestTree requestBrigSuccess = - testCase "should translate response from brig to 'InwardResponseBody' when response has status 200" $ + testCase "should translate response from brig to 'InwardResponseBody' when response has status 200" $ do + request <- + exampleRequest + "test/resources/unit/localhost.example.com.pem" + "/federation/brig/get-user-by-handle" runM . evalMock @Service @IO $ do - mockServiceCallReturns @IO (\_ _ _ _ -> pure (HTTP.ok200, Just "response body")) - let request = Request Brig "/federation/get-user-by-handle" "\"foo\"" exampleDomain + mockServiceCallReturns @IO (\_ _ _ _ -> pure (HTTP.ok200, Just "\"bar\"")) - exampleCert <- embed $ BS.readFile "test/resources/unit/localhost.example.com.pem" - res :: InwardResponse <- + res <- mock @Service @IO + . assertNoError @ValidationError + . assertNoError @DiscoveryFailure + . assertNoError @ServerError . TinyLog.discardLogs . mockDiscoveryTrivial - . Polysemy.runReader noClientCertSettings - $ callLocal (Just exampleCert) request + . runInputConst noClientCertSettings + $ callInward request actualCalls <- mockServiceCallCalls @IO - let expectedCall = (Brig, "federation/get-user-by-handle", "\"foo\"", aValidDomain) + let expectedCall = (Brig, "/federation/get-user-by-handle", "\"foo\"", aValidDomain) embed $ assertEqual "one call to brig should be made" [expectedCall] actualCalls - embed $ assertEqual "response should be success with correct body" (InwardResponseBody "response body") res + embed $ Wai.responseStatus res @?= HTTP.status200 + body <- embed $ Wai.lazyResponseBody res + embed $ body @?= "\"bar\"" requestBrigFailure :: TestTree requestBrigFailure = - testCase "should translate response from brig to 'InwardResponseError' when response has status 404" $ - runM . evalMock @Service @IO $ do - mockServiceCallReturns @IO (\_ _ _ _ -> pure (HTTP.notFound404, Just "response body")) - let request = Request Brig "/federation/get-user-by-handle" "\"foo\"" exampleDomain + testCase "should translate response from brig to 'InwardResponseError' when response has status 404" $ do + request <- + exampleRequest + "test/resources/unit/localhost.example.com.pem" + "/federation/brig/get-user-by-handle" - exampleCert <- embed $ BS.readFile "test/resources/unit/localhost.example.com.pem" + runM . evalMock @Service @IO $ do + let brigResponseBody = "response body" + mockServiceCallReturns @IO (\_ _ _ _ -> pure (HTTP.notFound404, Just brigResponseBody)) res <- mock @Service @IO + . assertNoError @ValidationError + . assertNoError @DiscoveryFailure + . assertNoError @ServerError . TinyLog.discardLogs . mockDiscoveryTrivial - . Polysemy.runReader noClientCertSettings - $ callLocal (Just exampleCert) request + . runInputConst noClientCertSettings + $ callInward request actualCalls <- mockServiceCallCalls @IO - let expectedCall = (Brig, "federation/get-user-by-handle", "\"foo\"", aValidDomain) + let expectedCall = (Brig, "/federation/get-user-by-handle", "\"foo\"", aValidDomain) embed $ assertEqual "one call to brig should be made" [expectedCall] actualCalls - embed $ case res of - InwardResponseBody b -> assertFailure ("expecting error, got success: " <> cs b) - InwardResponseError err -> assertEqual ("response should be InwardError 'IOther', but got:" <> show err) InwardError.IOther (inwardErrorType err) + embed $ Wai.responseStatus res @?= HTTP.notFound404 + body <- embed $ Wai.lazyResponseBody res + embed $ body @?= brigResponseBody requestGalleySuccess :: TestTree requestGalleySuccess = - testCase "should translate response from galley to 'InwardResponseBody' when response has status 200" $ + testCase "should forward response from galley when response has status 200" $ do + request <- + exampleRequest + "test/resources/unit/localhost.example.com.pem" + "/federation/galley/get-conversations" + runM . evalMock @Service @IO $ do - mockServiceCallReturns @IO (\_ _ _ _ -> pure (HTTP.ok200, Just "response body")) - let request = Request Galley "federation/get-conversations" "{}" exampleDomain + mockServiceCallReturns @IO (\_ _ _ _ -> pure (HTTP.ok200, Just "\"bar\"")) - exampleCert <- embed $ BS.readFile "test/resources/unit/localhost.example.com.pem" - res :: InwardResponse <- + res <- mock @Service @IO + . assertNoError @ValidationError + . assertNoError @DiscoveryFailure + . assertNoError @ServerError . TinyLog.discardLogs . mockDiscoveryTrivial - . Polysemy.runReader noClientCertSettings - $ callLocal (Just exampleCert) request + . runInputConst noClientCertSettings + $ callInward request actualCalls <- mockServiceCallCalls @IO - let expectedCall = (Galley, "federation/get-conversations", "{}", aValidDomain) - embed $ assertEqual "one call to brig should be made" [expectedCall] actualCalls - embed $ assertEqual "response should be success with correct body" (InwardResponseBody "response body") res + let expectedCall = (Galley, "/federation/get-conversations", "\"foo\"", aValidDomain) + embed $ assertEqual "one call to galley should be made" [expectedCall] actualCalls + embed $ Wai.responseStatus res @?= HTTP.status200 + body <- embed $ Wai.lazyResponseBody res + embed $ body @?= "\"bar\"" + +requestNoDomain :: TestTree +requestNoDomain = + testCase "should fail with a ServerError when no origin domain header is given" $ do + cert <- BS.readFile "test/resources/unit/localhost.example.com.pem" + request <- + testRequest + def + { trCertificateHeader = Just cert, + trPath = "/federation/brig/get-users" + } + + runM . evalMock @Service @IO $ do + mockServiceCallReturns @IO (\_ _ _ _ -> pure (HTTP.ok200, Just "\"bar\"")) + + res <- + runError + . mock @Service @IO + . assertNoError @ValidationError + . assertNoError @DiscoveryFailure + . TinyLog.discardLogs + . mockDiscoveryTrivial + . runInputConst noClientCertSettings + $ callInward request + + actualCalls <- mockServiceCallCalls @IO + embed $ assertEqual "no calls to services should be made" [] actualCalls + embed $ void res @?= Left NoOriginDomain + +requestNoCertificate :: TestTree +requestNoCertificate = + testCase "should fail with a ValidationError when no certificate is given" $ do + request <- + testRequest + def + { trDomainHeader = Just (Text.encodeUtf8 exampleDomain), + trPath = "/federation/brig/get-users" + } + + runM . evalMock @Service @IO $ do + mockServiceCallReturns @IO (\_ _ _ _ -> pure (HTTP.ok200, Just "\"bar\"")) + + res <- + runError + . mock @Service @IO + . assertNoError @ServerError + . assertNoError @DiscoveryFailure + . TinyLog.discardLogs + . mockDiscoveryTrivial + . runInputConst noClientCertSettings + $ callInward request + + actualCalls <- mockServiceCallCalls @IO + embed $ assertEqual "no calls to services should be made" [] actualCalls + embed $ void res @?= Left NoClientCertificate + +testInvalidPaths :: TestTree +testInvalidPaths = do + testCase "should not forward requests with invalid paths to services" $ do + let invalidPaths = + [ "", + "/", + "///", + -- disallowed paths + "federation", + "/federation", + "/federation/", + "/federation/brig", + "/federation/brig/", -- empty component + "i/users", + "/i/users", + "/federation/brig/too/many/components", + -- syntax we don't wish to support + "http://federation.wire.link/federation/galley", -- contains scheme and domain + "http://federation/stuff", -- contains scheme + "federation.wire.link/federation/brig/stuff", -- contains domain + "/federation/brig/rpc?bar[]=baz", -- queries not allowed + "/federation/brig/stuff?key=value", -- queries not allowed + -- rpc names that don't match [0-9a-zA-Z-_]+ + "/federation/brig/%2e%2e/i/users", -- percent-encoded '../' + "/federation/brig/%2E%2E/i/users", + "/federation/brig/..%2Fi%2Fusers", -- percent-encoded ../i/users + "/federation/brig/%252e%252e/i/users", -- double percent-encoded '../' + "/federation/brig/%c0%ae%c0%ae/i/users" -- weird-encoded '../' + ] + + for_ invalidPaths $ \invalidPath -> do + request <- + exampleRequest + "test/resources/unit/localhost.example.com.pem" + invalidPath + + runM . evalMock @Service @IO $ do + mockServiceCallReturns @IO (\_ _ _ _ -> pure (HTTP.ok200, Just "\"bar\"")) + + res <- + runError @ServerError + . mock @Service @IO + . assertNoError @ValidationError + . assertNoError @DiscoveryFailure + . TinyLog.discardLogs + . mockDiscoveryTrivial + . runInputConst noClientCertSettings + $ callInward request + + embed $ assertEqual ("Expected request with path \"" <> cs invalidPath <> "\" to fail") (Left InvalidRoute) (void res) + + actualCalls <- mockServiceCallCalls @IO + embed $ assertEqual "no calls to any service should be made" [] actualCalls + +testInvalidComponent :: TestTree +testInvalidComponent = + testCase "a path with an invalid component should result in an error" $ do + request <- + exampleRequest + "test/resources/unit/localhost.example.com.pem" + "/federation/mast/get-users" + + runM . evalMock @Service @IO $ do + mockServiceCallReturns @IO (\_ _ _ _ -> pure (HTTP.ok200, Just "\"bar\"")) + + res <- + runError @ServerError + . mock @Service @IO + . assertNoError @ValidationError + . assertNoError @DiscoveryFailure + . TinyLog.discardLogs + . mockDiscoveryTrivial + . runInputConst noClientCertSettings + $ callInward request + + embed $ void res @?= Left (UnknownComponent "mast") + actualCalls <- mockServiceCallCalls @IO + embed $ assertEqual "no calls to any service should be made" [] actualCalls + +testMethod :: TestTree +testMethod = + testCase "only POST should be supported" $ do + cert <- BS.readFile "test/resources/unit/localhost.example.com.pem" + let tr = + def + { trPath = "/federation/galley/send-message", + trDomainHeader = Just (Text.encodeUtf8 exampleDomain), + trCertificateHeader = Just cert, + trBody = "\"hello\"" + } + + for_ [HTTP.methodGet, HTTP.methodDelete, HTTP.methodPut, HTTP.methodPatch] $ \method -> do + request <- testRequest tr {trMethod = method} + res <- + runM + . runError @ServerError + . interpret @Service (\_ -> embed $ assertFailure "unexpected call to service") + . assertNoError @ValidationError + . assertNoError @DiscoveryFailure + . TinyLog.discardLogs + . mockDiscoveryTrivial + . runInputConst noClientCertSettings + $ callInward request + void res @?= Left InvalidRoute exampleDomain :: Text exampleDomain = "localhost.example.com" diff --git a/services/federator/test/unit/Test/Federator/InternalServer.hs b/services/federator/test/unit/Test/Federator/InternalServer.hs index 1d30b640cfb..3def6a2c2a9 100644 --- a/services/federator/test/unit/Test/Federator/InternalServer.hs +++ b/services/federator/test/unit/Test/Federator/InternalServer.hs @@ -19,35 +19,36 @@ module Test.Federator.InternalServer (tests) where -import Data.Domain (Domain (Domain)) -import Federator.Discovery (LookupError (LookupErrorDNSError, LookupErrorSrvNotAvailable)) +import Data.Binary.Builder +import Data.ByteString.Conversion +import Data.Default +import Data.Domain +import Federator.Error.ServerError import Federator.InternalServer (callOutward) import Federator.Options (AllowedDomains (..), FederationStrategy (..), RunSettings (..)) -import Federator.Remote (Remote, RemoteError (RemoteErrorDiscoveryFailure)) +import Federator.Remote +import Federator.Validation import Imports -import Mu.GRpc.Client.Record -import qualified Network.HTTP2.Client as HTTP2 -import Polysemy (embed, runM) -import qualified Polysemy.Reader as Polysemy +import qualified Network.HTTP.Types as HTTP +import qualified Network.Wai as Wai +import qualified Network.Wai.Utilities.Server as Wai +import Polysemy +import Polysemy.Error +import Polysemy.Input +import Polysemy.TinyLog import Test.Federator.Options (noClientCertSettings) -import Test.Polysemy.Mock (Mock (mock), evalMock) -import Test.Polysemy.Mock.TH (genMock) -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (assertEqual, assertFailure, testCase) -import Wire.API.Federation.GRPC.Types - -genMock ''Remote +import Test.Federator.Util +import Test.Tasty +import Test.Tasty.HUnit +import Wire.API.Federation.Component +import Wire.API.Federation.Domain tests :: TestTree tests = - testGroup "Federate" $ + testGroup + "Federate" [ testGroup "with remote" $ [ federatedRequestSuccess, - federatedRequestFailureTMC, - federatedRequestFailureErrCode, - federatedRequestFailureErrStr, - federatedRequestFailureNoRemote, - federatedRequestFailureDNS, federatedRequestFailureAllowList ] ] @@ -58,122 +59,63 @@ settingsWithAllowList domains = federatedRequestSuccess :: TestTree federatedRequestSuccess = - testCase "should successfully return success response" $ - runM . evalMock @Remote @IO $ do - mockDiscoverAndCallReturns @IO (const $ pure (Right (GRpcOk (InwardResponseBody "success!")))) - let federatedRequest = FederatedRequest validDomainText (Just validLocalPart) - - res <- - mock @Remote @IO . Polysemy.runReader noClientCertSettings $ - callOutward federatedRequest - - actualCalls <- mockDiscoverAndCallCalls @IO - let expectedCall = ValidatedFederatedRequest (Domain validDomainText) validLocalPart - embed $ assertEqual "one remote call should be made" [expectedCall] actualCalls - embed $ assertEqual "successful response should be returned" (OutwardResponseBody "success!") res - --- FUTUREWORK(federation): This is probably not ideal, we should figure out what this error --- means and act accordingly. -federatedRequestFailureTMC :: TestTree -federatedRequestFailureTMC = - testCase "should respond with error when facing GRpcTooMuchConcurrency" $ - runM . evalMock @Remote @IO $ do - mockDiscoverAndCallReturns @IO (const $ pure (Right (GRpcTooMuchConcurrency (HTTP2.TooMuchConcurrency 2)))) - let federatedRequest = FederatedRequest validDomainText (Just validLocalPart) - - res <- mock @Remote @IO . Polysemy.runReader noClientCertSettings $ callOutward federatedRequest - - actualCalls <- mockDiscoverAndCallCalls @IO - let expectedCall = ValidatedFederatedRequest (Domain validDomainText) validLocalPart - embed $ do - assertEqual "one remote call should be made" [expectedCall] actualCalls - assertResponseErrorWithType TooMuchConcurrency res - -federatedRequestFailureErrCode :: TestTree -federatedRequestFailureErrCode = - testCase "should respond with error when facing GRpcErrorCode" $ - runM . evalMock @Remote @IO $ do - mockDiscoverAndCallReturns @IO (const $ pure (Right (GRpcErrorCode 77))) -- TODO: Maybe use some legit HTTP2 error code? - let federatedRequest = FederatedRequest validDomainText (Just validLocalPart) - - res <- mock @Remote @IO . Polysemy.runReader noClientCertSettings $ callOutward federatedRequest - - actualCalls <- mockDiscoverAndCallCalls @IO - let expectedCall = ValidatedFederatedRequest (Domain validDomainText) validLocalPart - embed $ do - assertEqual "one remote call should be made" [expectedCall] actualCalls - assertResponseErrorWithType GrpcError res - -federatedRequestFailureErrStr :: TestTree -federatedRequestFailureErrStr = - testCase "should respond with error when facing GRpcErrorString" $ - runM . evalMock @Remote @IO $ do - mockDiscoverAndCallReturns @IO (const $ pure (Right (GRpcErrorString "some grpc error"))) - let federatedRequest = FederatedRequest validDomainText (Just validLocalPart) - - res <- mock @Remote @IO . Polysemy.runReader noClientCertSettings $ callOutward federatedRequest - - actualCalls <- mockDiscoverAndCallCalls @IO - let expectedCall = ValidatedFederatedRequest (Domain validDomainText) validLocalPart - embed $ do - assertEqual "one remote call should be made" [expectedCall] actualCalls - assertResponseErrorWithType GrpcError res - -federatedRequestFailureNoRemote :: TestTree -federatedRequestFailureNoRemote = - testCase "should respond with error when SRV record is not found" $ - runM . evalMock @Remote @IO $ do - mockDiscoverAndCallReturns @IO (const $ pure (Left $ RemoteErrorDiscoveryFailure (Domain "example.com") (LookupErrorSrvNotAvailable "_something._tcp.example.com"))) - let federatedRequest = FederatedRequest validDomainText (Just validLocalPart) - - res <- mock @Remote @IO . Polysemy.runReader noClientCertSettings $ callOutward federatedRequest - - actualCalls <- mockDiscoverAndCallCalls @IO - let expectedCall = ValidatedFederatedRequest (Domain validDomainText) validLocalPart - embed $ do - assertEqual "one remote call should be made" [expectedCall] actualCalls - assertResponseErrorWithType RemoteNotFound res - -federatedRequestFailureDNS :: TestTree -federatedRequestFailureDNS = - testCase "should respond with error when SRV lookup fails due to DNSError" $ - runM . evalMock @Remote @IO $ do - mockDiscoverAndCallReturns @IO (const $ pure (Left $ RemoteErrorDiscoveryFailure (Domain "example.com") (LookupErrorDNSError "No route to 1.1.1.1"))) - let federatedRequest = FederatedRequest validDomainText (Just validLocalPart) - - res <- mock @Remote @IO . Polysemy.runReader noClientCertSettings $ callOutward federatedRequest - - actualCalls <- mockDiscoverAndCallCalls @IO - let expectedCall = ValidatedFederatedRequest (Domain validDomainText) validLocalPart - embed $ do - assertEqual "one remote call should be made" [expectedCall] actualCalls - assertResponseErrorWithType DiscoveryFailed res + testCase "should successfully return success response" $ do + let settings = noClientCertSettings + let targetDomain = Domain "target.example.com" + requestHeaders = [(originDomainHeaderName, "origin.example.com")] + request <- + testRequest + def + { trPath = "/rpc/" <> toByteString' targetDomain <> "/brig/get-user-by-handle", + trBody = "\"foo\"", + trExtraHeaders = requestHeaders + } + let interpretCall :: Member (Embed IO) r => Sem (Remote ': r) a -> Sem r a + interpretCall = interpret $ \case + DiscoverAndCall domain component rpc headers body -> embed @IO $ do + domain @?= targetDomain + component @?= Brig + rpc @?= "get-user-by-handle" + headers @?= requestHeaders + toLazyByteString body @?= "\"foo\"" + pure (HTTP.status200, fromLazyByteString "\"bar\"") + res <- + runM + . interpretCall + . assertNoError @ValidationError + . assertNoError @ServerError + . discardLogs + . runInputConst settings + $ callOutward request + Wai.responseStatus res @?= HTTP.status200 + body <- Wai.lazyResponseBody res + body @?= "\"bar\"" federatedRequestFailureAllowList :: TestTree federatedRequestFailureAllowList = - testCase "should not make a call when target domain not in the allowList" $ - runM . evalMock @Remote @IO $ do - let federatedRequest = FederatedRequest validDomainText (Just validLocalPart) - let settings = settingsWithAllowList [Domain "hello.world"] - res <- mock @Remote @IO . Polysemy.runReader settings $ callOutward federatedRequest - - actualCalls <- mockDiscoverAndCallCalls @IO - embed $ do - assertEqual "no remote calls should be made" [] actualCalls - assertResponseErrorWithType FederationDeniedLocally res - -assertResponseErrorWithType :: HasCallStack => OutwardErrorType -> OutwardResponse -> IO () -assertResponseErrorWithType expectedType res = - case res of - OutwardResponseBody _ -> - assertFailure $ "Expected response to be error, but it was not: " <> show res - OutwardResponseInwardError err -> - assertFailure $ "Expected response to be outward error, but it was not: " <> show err - OutwardResponseError (OutwardError actualType _) -> - assertEqual "Unexpected error type" expectedType actualType - -validLocalPart :: Request -validLocalPart = Request Brig "/users" "\"foo\"" "foo.domain" - -validDomainText :: Text -validDomainText = "example.com" + testCase "should not make a call when target domain not in the allowList" $ do + let settings = settingsWithAllowList [Domain "hello.world"] + let targetDomain = Domain "target.example.com" + headers = [(originDomainHeaderName, "origin.example.com")] + request <- + testRequest + def + { trPath = "/rpc/" <> toByteString' targetDomain <> "/brig/get-user-by-handle", + trBody = "\"foo\"", + trExtraHeaders = headers + } + + let checkRequest :: Sem (Remote ': r) a -> Sem r a + checkRequest = interpret $ \case + DiscoverAndCall {} -> pure (HTTP.status200, fromLazyByteString "\"bar\"") + + eith <- + runM + . runError @ValidationError + . void + . checkRequest + . assertNoError @ServerError + . discardLogs + . runInputConst settings + $ callOutward request + eith @?= Left (FederationDenied targetDomain) diff --git a/services/federator/test/unit/Test/Federator/Remote.hs b/services/federator/test/unit/Test/Federator/Remote.hs index 61d105ed7f5..66689a26291 100644 --- a/services/federator/test/unit/Test/Federator/Remote.hs +++ b/services/federator/test/unit/Test/Federator/Remote.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE NumericUnderscores #-} - -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2021 Wire Swiss GmbH @@ -19,8 +17,11 @@ module Test.Federator.Remote where -import Data.Streaming.Network (bindRandomPortTCP) +import Control.Exception (bracket) +import Data.Domain +import Federator.Discovery import Federator.Env (TLSSettings) +import Federator.MockServer (startMockServer) import Federator.Options import Federator.Remote import Federator.Run (mkTLSSettingsOrThrow) @@ -28,28 +29,25 @@ import Imports import Network.HTTP.Types (status200) import Network.Wai import qualified Network.Wai.Handler.Warp as Warp -import qualified Network.Wai.Handler.WarpTLS as WarpTLS +import qualified Network.Wai.Handler.WarpTLS as Warp import Polysemy -import qualified Polysemy.Error as Polysemy -import qualified Polysemy.Input as Polysemy -import qualified Polysemy.Resource as Polysemy +import Polysemy.Error +import Polysemy.Input import Test.Federator.Options (defRunSettings) +import Test.Federator.Util import Test.Tasty import Test.Tasty.HUnit -import UnliftIO (bracket, timeout) -import qualified UnliftIO.Async as Async -import Wire.API.Federation.GRPC.Client +import Wire.API.Federation.Component +import Wire.API.Federation.Error import Wire.Network.DNS.SRV (SrvTarget (SrvTarget)) tests :: TestTree tests = testGroup "Federator.Remote" - [ testGroup - "mkGrpcClient" - [ testValidatesCertificateSuccess, - testValidatesCertificateWrongHostname - ] + [ testValidatesCertificateSuccess, + testValidatesCertificateWrongHostname, + testConnectionError ] settings :: RunSettings @@ -62,41 +60,58 @@ settings = remoteCAStore = Just "test/resources/unit/unit-ca.pem" } -assertNoError :: IO (Either RemoteError x) -> IO x -assertNoError action = +discoverLocalhost :: Int -> Sem (DiscoverFederator ': r) a -> Sem r a +discoverLocalhost port = interpret $ \case + DiscoverAllFederators (Domain "localhost") -> + pure (Right (pure (SrvTarget "localhost" (fromIntegral port)))) + DiscoverAllFederators _ -> pure (Left (DiscoveryFailureSrvNotAvailable "only localhost is supported")) + DiscoverFederator (Domain "localhost") -> + pure (Right (SrvTarget "localhost" (fromIntegral port))) + DiscoverFederator _ -> pure (Left (DiscoveryFailureSrvNotAvailable "only localhost is supported")) + +assertNoRemoteError :: IO (Either RemoteError x) -> IO x +assertNoRemoteError action = action >>= \case - Left err -> assertFailure $ "Unexpected error: " <> show err + Left err -> assertFailure $ "Unexpected remote error: " <> show err Right x -> pure x -mkTestGrpcClient :: TLSSettings -> Int -> IO (Either RemoteError ()) -mkTestGrpcClient tlsSettings port = - Polysemy.runM - . Polysemy.runResource - . Polysemy.runError - . Polysemy.runInputConst tlsSettings - $ do - Polysemy.bracket - (mkGrpcClient (SrvTarget "localhost" (fromIntegral port))) - (embed @IO . closeGrpcClient) - (const (pure ())) +mkTestCall :: TLSSettings -> Int -> IO (Either RemoteError ()) +mkTestCall tlsSettings port = + runM + . runError @RemoteError + . void + . runInputConst tlsSettings + . discoverLocalhost port + . assertNoError @DiscoveryFailure + . interpretRemote + $ discoverAndCall (Domain "localhost") Brig "test" [] mempty + +withMockServer :: Warp.TLSSettings -> (Warp.Port -> IO a) -> IO a +withMockServer tls k = + bracket + (startMockServer (Just tls) app) + fst + (k . snd) + where + app _req respond = respond $ responseLBS status200 [] "mock body" testValidatesCertificateSuccess :: TestTree testValidatesCertificateSuccess = testGroup "can get response with valid certificate" - [ testCase "when hostname=localhost and certificate-for=localhost" $ do - bracket (startMockServer certForLocalhost) (\(serverThread, _) -> Async.cancel serverThread) $ \(_, port) -> do + [ testCase "when hostname=localhost and certificate-for=localhost" $ + withMockServer certForLocalhost $ \port -> do tlsSettings <- mkTLSSettingsOrThrow settings - assertNoError (mkTestGrpcClient tlsSettings port), - testCase "when hostname=localhost. and certificate-for=localhost" $ do - bracket (startMockServer certForLocalhost) (\(serverThread, _) -> Async.cancel serverThread) $ \(_, port) -> do + assertNoRemoteError (mkTestCall tlsSettings port), + testCase "when hostname=localhost. and certificate-for=localhost" $ + withMockServer certForLocalhost $ \port -> do tlsSettings <- mkTLSSettingsOrThrow settings - assertNoError (mkTestGrpcClient tlsSettings port), + assertNoRemoteError (mkTestCall tlsSettings port), -- This is a limitation of the TLS library, this test just exists to document that. - testCase "when hostname=localhost. and certificate-for=localhost." $ do - bracket (startMockServer certForLocalhostDot) (\(serverThread, _) -> Async.cancel serverThread) $ \(_, port) -> do + testCase "when hostname=localhost. and certificate-for=localhost." $ + withMockServer certForLocalhostDot $ \port -> do tlsSettings <- mkTLSSettingsOrThrow settings - eitherClient <- mkTestGrpcClient tlsSettings port + eitherClient <- mkTestCall tlsSettings port case eitherClient of Left _ -> pure () Right _ -> assertFailure "Congratulations, you fixed a known issue!" @@ -107,58 +122,43 @@ testValidatesCertificateWrongHostname = testGroup "refuses to connect with server" [ testCase "when the server's certificate doesn't match the hostname" $ - bracket (startMockServer certForWrongDomain) (Async.cancel . fst) $ \(_, port) -> do + withMockServer certForWrongDomain $ \port -> do tlsSettings <- mkTLSSettingsOrThrow settings - eitherClient <- mkTestGrpcClient tlsSettings port + eitherClient <- mkTestCall tlsSettings port case eitherClient of - Left (RemoteErrorTLSException _ _) -> pure () + Left (RemoteError _ (FederatorClientTLSException _)) -> pure () Left x -> assertFailure $ "Expected TLS failure, got: " <> show x Right _ -> assertFailure "Expected connection with the server to fail", testCase "when the server's certificate does not have the server key usage flag" $ - bracket (startMockServer certWithoutServerKeyUsage) (Async.cancel . fst) $ \(_, port) -> do + withMockServer certWithoutServerKeyUsage $ \port -> do tlsSettings <- mkTLSSettingsOrThrow settings - eitherClient <- mkTestGrpcClient tlsSettings port + eitherClient <- mkTestCall tlsSettings port case eitherClient of - Left (RemoteErrorTLSException _ _) -> pure () + Left (RemoteError _ (FederatorClientTLSException _)) -> pure () Left x -> assertFailure $ "Expected TLS failure, got: " <> show x Right _ -> assertFailure "Expected connection with the server to fail" ] -certForLocalhost :: WarpTLS.TLSSettings -certForLocalhost = WarpTLS.tlsSettings "test/resources/unit/localhost.pem" "test/resources/unit/localhost-key.pem" +testConnectionError :: TestTree +testConnectionError = testCase "connection failures are reported correctly" $ do + tlsSettings <- mkTLSSettingsOrThrow settings + result <- mkTestCall tlsSettings 1 + case result of + Left (RemoteError _ (FederatorClientConnectionError _)) -> pure () + Left x -> assertFailure $ "Expected connection error, got: " <> show x + Right _ -> assertFailure "Expected connection with the server to fail" -certForLocalhostDot :: WarpTLS.TLSSettings -certForLocalhostDot = WarpTLS.tlsSettings "test/resources/unit/localhost-dot.pem" "test/resources/unit/localhost-dot-key.pem" +certForLocalhost :: Warp.TLSSettings +certForLocalhost = Warp.tlsSettings "test/resources/unit/localhost.pem" "test/resources/unit/localhost-key.pem" -certForWrongDomain :: WarpTLS.TLSSettings -certForWrongDomain = WarpTLS.tlsSettings "test/resources/unit/localhost.example.com.pem" "test/resources/unit/localhost.example.com-key.pem" +certForLocalhostDot :: Warp.TLSSettings +certForLocalhostDot = Warp.tlsSettings "test/resources/unit/localhost-dot.pem" "test/resources/unit/localhost-dot-key.pem" -certWithoutServerKeyUsage :: WarpTLS.TLSSettings +certForWrongDomain :: Warp.TLSSettings +certForWrongDomain = Warp.tlsSettings "test/resources/unit/localhost.example.com.pem" "test/resources/unit/localhost.example.com-key.pem" + +certWithoutServerKeyUsage :: Warp.TLSSettings certWithoutServerKeyUsage = - WarpTLS.tlsSettings + Warp.tlsSettings "test/resources/unit/localhost.client-only.pem" "test/resources/unit/localhost.client-only-key.pem" - -startMockServer :: MonadIO m => WarpTLS.TLSSettings -> m (Async.Async (), Warp.Port) -startMockServer tlsSettings = liftIO $ do - (port, sock) <- bindRandomPortTCP "*6" - serverStarted <- newEmptyMVar - let wsettings = - Warp.defaultSettings - & Warp.setPort port - & Warp.setGracefulCloseTimeout2 0 -- Defaults to 2 seconds, causes server stop to take very long - & Warp.setBeforeMainLoop (putMVar serverStarted ()) - app _req respond = respond $ responseLBS status200 [] "dragons be here" - - serverThread <- Async.async $ WarpTLS.runTLSSocket tlsSettings wsettings sock app - serverStartedSignal <- timeout 10_000_000 (readMVar serverStarted) - case serverStartedSignal of - Nothing -> do - maybeException <- Async.poll serverThread - case maybeException of - Just (Left err) -> assertFailure $ "mock server errored while starting: \n" <> show err - _ -> pure () - liftIO $ Async.cancel serverThread - assertFailure $ "Failed to start the mock server within 10 seconds on port: " <> show port - _ -> do - pure (serverThread, port) diff --git a/services/federator/test/unit/Test/Federator/Response.hs b/services/federator/test/unit/Test/Federator/Response.hs new file mode 100644 index 00000000000..8413b9b95a2 --- /dev/null +++ b/services/federator/test/unit/Test/Federator/Response.hs @@ -0,0 +1,91 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2020 Wire Swiss GmbH +-- +-- 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 . + +module Test.Federator.Response (tests) where + +import qualified Data.Aeson as Aeson +import Federator.Discovery +import Federator.Error.ServerError (ServerError (..)) +import Federator.Remote +import Federator.Response (runWaiError) +import Federator.Validation +import Imports +import qualified Network.HTTP.Types as HTTP +import qualified Network.Wai as Wai +import qualified Network.Wai.Utilities.Error as Wai +import qualified Network.Wai.Utilities.Server as Wai +import Polysemy +import Polysemy.Error +import qualified Polysemy.TinyLog as TinyLog +import Test.Tasty +import Test.Tasty.HUnit +import Wire.API.Federation.Error +import Wire.Network.DNS.SRV + +tests :: TestTree +tests = + testGroup + "Wai Errors" + [ testValidationError, + testServerError, + testDiscoveryFailure, + testRemoteError + ] + +testValidationError :: TestTree +testValidationError = + testCase "validation errors should be converted to wai error responses" $ do + resp <- runM . TinyLog.discardLogs . runWaiError @ValidationError $ throw NoClientCertificate + body <- Wai.lazyResponseBody resp + let merr = Aeson.decode body + Wai.responseStatus resp @?= HTTP.status403 + fmap Wai.label merr @?= Just "no-client-certificate" + +testServerError :: TestTree +testServerError = + testCase "server errors should be converted to wai error responses" $ do + resp <- runM . TinyLog.discardLogs . runWaiError @ServerError $ throw InvalidRoute + body <- Wai.lazyResponseBody resp + let merr = Aeson.decode body + Wai.responseStatus resp @?= HTTP.status403 + fmap Wai.label merr @?= Just "invalid-endpoint" + +testDiscoveryFailure :: TestTree +testDiscoveryFailure = + testCase "discovery failures should be converted to wai error responses" $ do + resp <- + runM . TinyLog.discardLogs . runWaiError @DiscoveryFailure $ + throw (DiscoveryFailureDNSError "mock error") + body <- Wai.lazyResponseBody resp + let merr = Aeson.decode body + Wai.responseStatus resp @?= HTTP.status500 + fmap Wai.label merr @?= Just "discovery-failure" + +testRemoteError :: TestTree +testRemoteError = + testCase "remote errors should be converted to wai error responses" $ do + resp <- + runM . TinyLog.discardLogs . runWaiError @RemoteError $ + throw + ( RemoteError + (SrvTarget "example.com" 7777) + FederatorClientNoStatusCode + ) + body <- Wai.lazyResponseBody resp + let merr = Aeson.decode body + Wai.responseStatus resp @?= toEnum 533 + fmap Wai.label merr @?= Just "federation-http2-error" diff --git a/services/federator/test/unit/Test/Federator/Util.hs b/services/federator/test/unit/Test/Federator/Util.hs new file mode 100644 index 00000000000..a299276c396 --- /dev/null +++ b/services/federator/test/unit/Test/Federator/Util.hs @@ -0,0 +1,73 @@ +{-# OPTIONS_GHC -Wno-warnings-deprecations #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- 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 . + +module Test.Federator.Util where + +import qualified Data.ByteString.Lazy as LBS +import Data.Default +import Imports +import qualified Network.HTTP.Types as HTTP +import qualified Network.Wai as Wai +import qualified Network.Wai.Test as Wai +import Polysemy +import Polysemy.Error +import Test.Tasty.HUnit +import Wire.API.Federation.Domain + +assertNoError :: (Show e, Member (Embed IO) r) => Sem (Error e ': r) x -> Sem r x +assertNoError = + runError >=> \case + Left err -> embed @IO . assertFailure $ "Unexpected error: " <> show err + Right x -> pure x + +data TestRequest = TestRequest + { trCertificateHeader :: Maybe ByteString, + trDomainHeader :: Maybe ByteString, + trPath :: ByteString, + trBody :: LByteString, + trMethod :: HTTP.Method, + trExtraHeaders :: [HTTP.Header] + } + +instance Default TestRequest where + def = + TestRequest + { trCertificateHeader = Nothing, + trDomainHeader = Nothing, + trPath = mempty, + trBody = mempty, + trMethod = HTTP.methodPost, + trExtraHeaders = [("Content-Type", "application/json")] + } + +testRequest :: TestRequest -> IO Wai.Request +testRequest tr = do + refChunks <- liftIO $ newIORef $ LBS.toChunks (trBody tr) + pure . flip Wai.setPath (trPath tr) $ + Wai.defaultRequest + { Wai.requestMethod = trMethod tr, + Wai.requestBody = atomicModifyIORef refChunks $ \bss -> + case bss of + [] -> ([], mempty) + x : y -> (y, x), + Wai.requestHeaders = + [("X-SSL-Certificate", HTTP.urlEncode True h) | h <- toList (trCertificateHeader tr)] + <> [(originDomainHeaderName, h) | h <- toList (trDomainHeader tr)] + <> trExtraHeaders tr + } diff --git a/services/federator/test/unit/Test/Federator/Validation.hs b/services/federator/test/unit/Test/Federator/Validation.hs index a79cc36dd0b..4c4597a6c51 100644 --- a/services/federator/test/unit/Test/Federator/Validation.hs +++ b/services/federator/test/unit/Test/Federator/Validation.hs @@ -20,23 +20,23 @@ module Test.Federator.Validation where import qualified Data.ByteString as BS +import Data.ByteString.Conversion import Data.Domain (Domain (..), domainText) import Data.List.NonEmpty (NonEmpty (..)) -import Data.String.Conversions import qualified Data.Text.Encoding as Text -import Federator.Discovery (DiscoverFederator (..), LookupError (..)) +import qualified Data.X509.Validation as X509 +import Federator.Discovery import Federator.Options import Federator.Validation import Imports -import Polysemy (Sem, run) -import qualified Polysemy -import qualified Polysemy.Error as Polysemy -import qualified Polysemy.Reader as Polysemy +import Polysemy +import Polysemy.Error +import Polysemy.Input import Test.Federator.InternalServer () import Test.Federator.Options (noClientCertSettings) +import Test.Federator.Util import Test.Tasty import Test.Tasty.HUnit -import Wire.API.Federation.GRPC.Types import Wire.Network.DNS.SRV (SrvTarget (..)) mockDiscoveryTrivial :: Sem (DiscoverFederator ': r) x -> Sem r x @@ -51,12 +51,12 @@ mockDiscoveryMapping origin targets = Polysemy.interpret $ \case pure $ if dom == origin then Right $ fmap (`SrvTarget` 443) targets - else Left $ LookupErrorSrvNotAvailable "invalid origin domain" + else Left $ DiscoveryFailureSrvNotAvailable "invalid origin domain" mockDiscoveryFailure :: HasCallStack => Sem (DiscoverFederator ': r) x -> Sem r x mockDiscoveryFailure = Polysemy.interpret $ \case DiscoverFederator _ -> error "Not mocked" - DiscoverAllFederators _ -> pure . Left $ LookupErrorDNSError "mock DNS error" + DiscoverAllFederators _ -> pure . Left $ DiscoveryFailureDNSError "mock DNS error" tests :: TestTree tests = @@ -76,51 +76,56 @@ tests = validateDomainMultipleFederators, validateDomainDiscoveryFailed, validateDomainNonIdentitySRV - ], - testGroup "validatePath - Success" validatePathSuccess, - testGroup "validatePath - Normalize" validatePathNormalize, - testGroup "validatePath - Forbid" validatePathForbidden + ] ] federateWithAllowListSuccess :: TestTree federateWithAllowListSuccess = testCase "should give True when target domain is in the list" $ do let settings = settingsWithAllowList [Domain "hello.world"] - res = run . Polysemy.runReader settings $ federateWith (Domain "hello.world") - assertBool "federating should be allowed" res + runM + . assertNoError @ValidationError + . runInputConst settings + $ ensureCanFederateWith (Domain "hello.world") federateWithAllowListFail :: TestTree federateWithAllowListFail = testCase "should give False when target domain is not in the list" $ do let settings = settingsWithAllowList [Domain "only.other.domain"] - res = run . Polysemy.runReader settings $ federateWith (Domain "hello.world") - assertBool "federating should not be allowed" (not res) + eith :: Either ValidationError () <- + runM + . runError @ValidationError + . runInputConst settings + $ ensureCanFederateWith (Domain "hello.world") + assertBool "federating should not be allowed" (isLeft eith) validateDomainAllowListFailSemantic :: TestTree validateDomainAllowListFailSemantic = testCase "semantic validation" $ do exampleCert <- BS.readFile "test/resources/unit/localhost.pem" let settings = settingsWithAllowList [Domain "only.other.domain"] - res :: Either InwardError Domain = - run - . Polysemy.runError - . mockDiscoveryTrivial - . Polysemy.runReader settings - $ validateDomain (Just exampleCert) ("invalid//.><-semantic-&@-domain" :: Text) - res @?= Left (InwardError IAuthenticationFailed "Domain parse failure for [invalid//.><-semantic-&@-domain]: Failed reading: Invalid domain name: cannot be dotless domain") + res <- + runM + . runError + . assertNoError @DiscoveryFailure + . mockDiscoveryTrivial + . runInputConst settings + $ validateDomain (Just exampleCert) "invalid//.><-semantic-&@-domain" + res @?= Left (DomainParseError "invalid//.><-semantic-&@-domain") validateDomainAllowListFail :: TestTree validateDomainAllowListFail = testCase "allow list validation" $ do exampleCert <- BS.readFile "test/resources/unit/localhost.example.com.pem" let settings = settingsWithAllowList [Domain "only.other.domain"] - res :: Either InwardError Domain = - run - . Polysemy.runError - . mockDiscoveryTrivial - . Polysemy.runReader settings - $ validateDomain (Just exampleCert) ("localhost.example.com" :: Text) - res @?= Left (InwardError IFederationDeniedByRemote "Origin domain [localhost.example.com] not in the federation allow list") + res <- + runM + . runError + . assertNoError @DiscoveryFailure + . mockDiscoveryTrivial + . runInputConst settings + $ validateDomain (Just exampleCert) "localhost.example.com" + res @?= Left (FederationDenied (Domain "localhost.example.com")) validateDomainAllowListSuccess :: TestTree validateDomainAllowListSuccess = @@ -128,56 +133,62 @@ validateDomainAllowListSuccess = exampleCert <- BS.readFile "test/resources/unit/localhost.example.com.pem" let domain = Domain "localhost.example.com" settings = settingsWithAllowList [domain] - res :: Either InwardError Domain = - run - . Polysemy.runError - . mockDiscoveryTrivial - . Polysemy.runReader settings - $ validateDomain (Just exampleCert) (domainText domain) - assertEqual "validateDomain should give 'localhost.example.com' as domain" (Right domain) res + res <- + runM + . assertNoError @ValidationError + . assertNoError @DiscoveryFailure + . mockDiscoveryTrivial + . runInputConst settings + $ validateDomain (Just exampleCert) (toByteString' domain) + assertEqual "validateDomain should give 'localhost.example.com' as domain" domain res validateDomainCertMissing :: TestTree validateDomainCertMissing = testCase "should fail if no client certificate is provided" $ do - let res :: Either InwardError Domain = - run . Polysemy.runError - . mockDiscoveryTrivial - . Polysemy.runReader noClientCertSettings - $ validateDomain Nothing "foo.example.com" - res @?= Left (InwardError IAuthenticationFailed "no client certificate provided") + res <- + runM . runError + . assertNoError @DiscoveryFailure + . mockDiscoveryTrivial + . runInputConst noClientCertSettings + $ validateDomain Nothing "foo.example.com" + res @?= Left NoClientCertificate validateDomainCertInvalid :: TestTree validateDomainCertInvalid = testCase "should fail if the client certificate is invalid" $ do - let res :: Either InwardError Domain = - run . Polysemy.runError - . mockDiscoveryTrivial - . Polysemy.runReader noClientCertSettings - $ validateDomain (Just "not a certificate") "foo.example.com" - res @?= Left (InwardError IAuthenticationFailed "no certificate found") + res <- + runM . runError + . assertNoError @DiscoveryFailure + . mockDiscoveryTrivial + . runInputConst noClientCertSettings + $ validateDomain (Just "not a certificate") "foo.example.com" + res @?= Left (CertificateParseError "no certificate found") validateDomainCertWrongDomain :: TestTree validateDomainCertWrongDomain = testCase "should fail if the client certificate has a wrong domain" $ do exampleCert <- BS.readFile "test/resources/unit/localhost.example.com.pem" - let res :: Either InwardError Domain = - run . Polysemy.runError - . mockDiscoveryTrivial - . Polysemy.runReader noClientCertSettings - $ validateDomain (Just exampleCert) "foo.example.com" - res @?= Left (InwardError IAuthenticationFailed "none of the domain names match the certificate, errrors: [[NameMismatch \"foo.example.com\"]]") + res <- + runM . runError + . assertNoError @DiscoveryFailure + . mockDiscoveryTrivial + . runInputConst noClientCertSettings + $ validateDomain (Just exampleCert) "foo.example.com" + res @?= Left (AuthenticationFailure (pure [X509.NameMismatch "foo.example.com"])) validateDomainCertCN :: TestTree validateDomainCertCN = testCase "should succeed if the certificate has subject CN but no SAN" $ do exampleCert <- BS.readFile "test/resources/unit/example.com.pem" let domain = Domain "foo.example.com" - res :: Either InwardError Domain = - run . Polysemy.runError - . mockDiscoveryTrivial - . Polysemy.runReader noClientCertSettings - $ validateDomain (Just exampleCert) (domainText domain) - res @?= Right domain + res <- + runM + . assertNoError @ValidationError + . assertNoError @DiscoveryFailure + . mockDiscoveryTrivial + . runInputConst noClientCertSettings + $ validateDomain (Just exampleCert) (toByteString' domain) + res @?= domain validateDomainMultipleFederators :: TestTree validateDomainMultipleFederators = @@ -185,115 +196,47 @@ validateDomainMultipleFederators = localhostExampleCert <- BS.readFile "test/resources/unit/localhost.example.com.pem" secondExampleCert <- BS.readFile "test/resources/unit/second-federator.example.com.pem" let runValidation = - run - . Polysemy.runError + runM + . assertNoError @ValidationError + . assertNoError @DiscoveryFailure . mockDiscoveryMapping domain ("localhost.example.com" :| ["second-federator.example.com"]) - . Polysemy.runReader noClientCertSettings + . runInputConst noClientCertSettings domain = Domain "foo.example.com" - resFirst :: Either InwardError Domain = - runValidation $ validateDomain (Just localhostExampleCert) (domainText domain) - resFirst @?= Right domain - let resSecond :: Either InwardError Domain = - runValidation $ validateDomain (Just secondExampleCert) (domainText domain) - resSecond @?= Right domain - + resFirst <- + runValidation $ + validateDomain (Just localhostExampleCert) (toByteString' domain) + resFirst @?= domain + resSecond <- + runValidation $ + validateDomain (Just secondExampleCert) (toByteString' domain) + resSecond @?= domain + +-- FUTUREWORK: is this test really necessary? validateDomainDiscoveryFailed :: TestTree validateDomainDiscoveryFailed = testCase "should fail if discovery fails" $ do exampleCert <- BS.readFile "test/resources/unit/example.com.pem" - let res :: Either InwardError Domain = - run . Polysemy.runError - . mockDiscoveryFailure - . Polysemy.runReader noClientCertSettings - $ validateDomain (Just exampleCert) "example.com" - res @?= Left (InwardError IDiscoveryFailed "DNS error: mock DNS error") + res <- + runM . runError + . assertNoError @ValidationError + . mockDiscoveryFailure + . runInputConst noClientCertSettings + $ validateDomain (Just exampleCert) "example.com" + res @?= Left (DiscoveryFailureDNSError "mock DNS error") validateDomainNonIdentitySRV :: TestTree validateDomainNonIdentitySRV = testCase "should run discovery to look up the federator domain" $ do exampleCert <- BS.readFile "test/resources/unit/localhost.example.com.pem" let domain = Domain "foo.example.com" - res :: Either InwardError Domain = - run . Polysemy.runError - . mockDiscoveryMapping domain ("localhost.example.com" :| []) - . Polysemy.runReader noClientCertSettings - $ validateDomain (Just exampleCert) (domainText domain) - res @?= Right domain - -validatePathSuccess :: [TestTree] -validatePathSuccess = do - let paths = - [ "federation/get-user-by-handle", - "federation/get-conversations" - ] - expectOk <$> paths - where - expectOk :: ByteString -> TestTree - expectOk path = testCase ("should allow " <> cs path) $ do - runSanitize path @?= Right path - -validatePathNormalize :: [TestTree] -validatePathNormalize = do - let paths = - [ ("federation//stuff", "federation/stuff"), - ("/federation/get-user-by-handle", "federation/get-user-by-handle"), - ("federation/../federation/stuff", "federation/stuff") - ] - expectNormalized <$> paths - where - expectNormalized :: (ByteString, ByteString) -> TestTree - expectNormalized (input, output) = do - testCase ("Should allow " <> cs input <> " and normalize to " <> cs output) $ do - runSanitize input @?= Right output - -validatePathForbidden :: [TestTree] -validatePathForbidden = do - let paths = - [ "", - "/", - "///", - -- disallowed paths - "federation", - "/federation", - "/federation/", - "i/users", - "/i/users", - -- path traversals to avoid - "../i/users", - "federation/../i/users", - "federation/%2e%2e/i/users", -- percent-encoded '../' - "federation/%2E%2E/i/users", - "federation/%252e%252e/i/users", -- double percent-encoded '../' - "federation/%c0%ae%c0%ae/i/users", -- weird-encoded '../' - -- syntax we don't wish to support - "federation/é", -- not ASCII - "federation/stuff?bar[]=baz", -- not parseable as URI - "http://federation.wire.link/federation/stuff", -- contains scheme and domain - "http://federation/stuff", -- contains scheme - "federation.wire.link/federation/stuff", -- contains domain - "federation/stuff?key=value", -- contains query parameter - "federation/stuff%3fkey%3dvalue", -- contains query parameter - "federation/stuff#fragment", -- contains fragment - "federation/stuff%23fragment", -- contains fragment - "federation/this-url-is-waaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaay-too-long" - ] - expectForbidden <$> paths - where - expectForbidden :: ByteString -> TestTree - expectForbidden input = do - testCase ("Should forbid '" <> cs (BS.take 40 input) <> "'") $ do - let res = runSanitize input - expectErr IForbiddenEndpoint res - -runSanitize :: ByteString -> Either InwardError ByteString -runSanitize = run . Polysemy.runError @InwardError . sanitizePath - -expectErr :: InwardErrorType -> Either InwardError ByteString -> IO () -expectErr expectedType (Right bdy) = do - assertFailure $ "expected error '" <> show expectedType <> "' but got a valid body: " <> show bdy -expectErr expectedType (Left err) = - unless (inwardErrorType err == expectedType) $ do - assertFailure $ "expected type '" <> show expectedType <> "' but got " <> show err + res <- + runM + . assertNoError @ValidationError + . assertNoError @DiscoveryFailure + . mockDiscoveryMapping domain ("localhost.example.com" :| []) + . runInputConst noClientCertSettings + $ validateDomain (Just exampleCert) (toByteString' domain) + res @?= domain settingsWithAllowList :: [Domain] -> RunSettings settingsWithAllowList domains = diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index 12da3f35501..2d762d9fa26 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 3186b74c21301ff760ffae6e280c4e15ee9d184c18aaaf106251cc8edc821c03 +-- hash: a1c3b8a4df30c11f5be17b3ba16e33ebb8a41438a7cec720761222a90f271f4e name: galley version: 0.83.0 @@ -106,7 +106,6 @@ library Galley.Intra.Client Galley.Intra.Effects Galley.Intra.Federator - Galley.Intra.Federator.Types Galley.Intra.Journal Galley.Intra.Push Galley.Intra.Push.Internal @@ -164,7 +163,6 @@ library , http-client-tls >=0.2.2 , http-media , http-types >=0.8 - , http2-client-grpc , imports , insert-ordered-containers , lens >=4.4 @@ -298,6 +296,7 @@ executable galley-integration , exceptions , extended , extra >=1.3 + , federator , galley , galley-types , gundeck-types diff --git a/services/galley/package.yaml b/services/galley/package.yaml index bf8e5ee19eb..e0b49c8d9ab 100644 --- a/services/galley/package.yaml +++ b/services/galley/package.yaml @@ -57,7 +57,6 @@ library: - http-client-tls >=0.2.2 - http-media - http-types >=0.8 - - http2-client-grpc - insert-ordered-containers - lens >=4.4 - memory @@ -173,6 +172,7 @@ executables: - data-timeout - errors - exceptions + - federator - galley - galley-types - gundeck-types diff --git a/services/galley/src/Galley/API/Action.hs b/services/galley/src/Galley/API/Action.hs index 957ccea7821..92f0f94831d 100644 --- a/services/galley/src/Galley/API/Action.hs +++ b/services/galley/src/Galley/API/Action.hs @@ -72,8 +72,9 @@ import Wire.API.Conversation.Action import Wire.API.Conversation.Role import Wire.API.ErrorDescription import Wire.API.Event.Conversation hiding (Conversation) +import Wire.API.Federation.API import qualified Wire.API.Federation.API.Galley as F -import Wire.API.Federation.Client +import Wire.API.Federation.Error import Wire.API.Team.LegalHold import Wire.API.Team.Member @@ -523,7 +524,7 @@ notifyConversationAction quid con lcnv targets action = do -- notify remote participants E.runFederatedConcurrently_ (toList (bmRemotes targets)) $ \ruids -> - F.onConversationUpdated F.clientRoutes (tDomain lcnv) $ + F.onConversationUpdated clientRoutes $ F.ConversationUpdate now quid (tUnqualified lcnv) (tUnqualified ruids) action -- notify local participants and bots diff --git a/services/galley/src/Galley/API/Create.hs b/services/galley/src/Galley/API/Create.hs index 4e8df3936b4..89b2ba348b6 100644 --- a/services/galley/src/Galley/API/Create.hs +++ b/services/galley/src/Galley/API/Create.hs @@ -63,7 +63,7 @@ import Wire.API.Conversation hiding (Conversation, Member) import qualified Wire.API.Conversation as Public import Wire.API.ErrorDescription import Wire.API.Event.Conversation hiding (Conversation) -import Wire.API.Federation.Client +import Wire.API.Federation.Error import Wire.API.Routes.Public.Galley (ConversationResponse) import Wire.API.Routes.Public.Util import Wire.API.Team.LegalHold (LegalholdProtectee (LegalholdPlusFederationNotImplemented)) diff --git a/services/galley/src/Galley/API/Error.hs b/services/galley/src/Galley/API/Error.hs index 34c6ec0d3c8..fb3a448d1b0 100644 --- a/services/galley/src/Galley/API/Error.hs +++ b/services/galley/src/Galley/API/Error.hs @@ -35,7 +35,6 @@ import Servant.API.Status (KnownStatus (..)) import Wire.API.Conversation (ConvType (..)) import Wire.API.Conversation.Role (Action) import Wire.API.ErrorDescription -import Wire.API.Federation.Client import Wire.API.Federation.Error ---------------------------------------------------------------------------- diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index 155a0f7e1de..1dbc5805967 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -52,6 +52,7 @@ import Polysemy.Error import Polysemy.Input import qualified Polysemy.TinyLog as P import Servant (ServerT) +import Servant.API import Servant.API.Generic (ToServantApi) import Servant.Server.Generic (genericServerT) import qualified System.Logger.Class as Log @@ -60,16 +61,19 @@ import Wire.API.Conversation.Action import Wire.API.Conversation.Member (OtherMember (..)) import qualified Wire.API.Conversation.Role as Public import Wire.API.Event.Conversation +import Wire.API.Federation.API import Wire.API.Federation.API.Common (EmptyResponse (..)) import qualified Wire.API.Federation.API.Galley as F import Wire.API.Routes.Internal.Brig.Connection import Wire.API.ServantProto import Wire.API.User.Client (userClientMap) -federationSitemap :: ServerT (ToServantApi F.Api) (Sem GalleyEffects) +type FederationAPI = "federation" :> ToServantApi (FedApi 'Galley) + +federationSitemap :: ServerT FederationAPI (Sem GalleyEffects) federationSitemap = genericServerT $ - F.Api + F.GalleyApi { F.onConversationCreated = onConversationCreated, F.getConversations = getConversations, F.onConversationUpdated = onConversationUpdated, @@ -366,9 +370,9 @@ onUserDeleted :: F.UserDeletedConversationsNotification -> Sem r EmptyResponse onUserDeleted origDomain udcn = do - let deletedUser = toRemoteUnsafe origDomain (F.udcnUser udcn) + let deletedUser = toRemoteUnsafe origDomain (F.udcvUser udcn) untaggedDeletedUser = qUntagged deletedUser - convIds = F.udcnConversations udcn + convIds = F.udcvConversations udcn E.spawnMany $ fromRange convIds <&> \c -> do diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index 5c5a555b927..357bd971b75 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -95,9 +95,9 @@ import qualified System.Logger.Class as Log import Wire.API.Conversation (ConvIdsPage, pattern GetPaginatedConversationIds) import Wire.API.Conversation.Action (ConversationAction (ConversationActionRemoveMembers)) import Wire.API.ErrorDescription -import Wire.API.Federation.API.Galley (ConversationUpdate (..), UserDeletedConversationsNotification (UserDeletedConversationsNotification)) -import qualified Wire.API.Federation.API.Galley as FedGalley -import Wire.API.Federation.Client (FederationError) +import Wire.API.Federation.API +import Wire.API.Federation.API.Galley hiding (getConversations) +import Wire.API.Federation.Error import Wire.API.Routes.MultiTablePaging (mtpHasMore, mtpPagingState, mtpResults) import Wire.API.Routes.MultiVerb (MultiVerb, RespondEmpty) import Wire.API.Routes.Public (ZLocalUser, ZOptConn) @@ -597,15 +597,15 @@ rmUser lusr conn = do cuAlreadyPresentUsers = tUnqualified remotes, cuAction = ConversationActionRemoveMembers (pure qUser) } - let rpc = FedGalley.onConversationUpdated FedGalley.clientRoutes (tDomain lusr) convUpdate + let rpc = onConversationUpdated clientRoutes convUpdate runFederatedEither remotes rpc >>= logAndIgnoreError "Error in onConversationUpdated call" (qUnqualified qUser) - leaveRemoteConversations :: Range 1 FedGalley.UserDeletedNotificationMaxConvs [Remote ConvId] -> Sem r () + leaveRemoteConversations :: Range 1 UserDeletedNotificationMaxConvs [Remote ConvId] -> Sem r () leaveRemoteConversations cids = do for_ (bucketRemote (fromRange cids)) $ \remoteConvs -> do let userDelete = UserDeletedConversationsNotification (tUnqualified lusr) (unsafeRange (tUnqualified remoteConvs)) - let rpc = FedGalley.onUserDeleted FedGalley.clientRoutes (tDomain lusr) userDelete + let rpc = onUserDeleted clientRoutes userDelete runFederatedEither remoteConvs rpc >>= logAndIgnoreError "Error in onUserDeleted call" (tUnqualified lusr) diff --git a/services/galley/src/Galley/API/LegalHold.hs b/services/galley/src/Galley/API/LegalHold.hs index 5bbe62a2362..a8f3cc7cb4c 100644 --- a/services/galley/src/Galley/API/LegalHold.hs +++ b/services/galley/src/Galley/API/LegalHold.hs @@ -79,7 +79,7 @@ import qualified System.Logger.Class as Log import Wire.API.Conversation (ConvType (..)) import Wire.API.Conversation.Role (roleNameWireAdmin) import Wire.API.ErrorDescription -import Wire.API.Federation.Client +import Wire.API.Federation.Error import Wire.API.Routes.Internal.Brig.Connection import qualified Wire.API.Team.Feature as Public import Wire.API.Team.LegalHold (LegalholdProtectee (LegalholdPlusFederationNotImplemented)) diff --git a/services/galley/src/Galley/API/Message.hs b/services/galley/src/Galley/API/Message.hs index 4d32905836d..d67099657ef 100644 --- a/services/galley/src/Galley/API/Message.hs +++ b/services/galley/src/Galley/API/Message.hs @@ -44,10 +44,10 @@ import Polysemy.Input import qualified Polysemy.TinyLog as P import qualified System.Logger.Class as Log import Wire.API.Event.Conversation -import qualified Wire.API.Federation.API.Brig as FederatedBrig -import qualified Wire.API.Federation.API.Galley as FederatedGalley -import Wire.API.Federation.Client (FederationError) -import Wire.API.Federation.Error (federationErrorToWai) +import Wire.API.Federation.API +import Wire.API.Federation.API.Brig +import Wire.API.Federation.API.Galley +import Wire.API.Federation.Error import Wire.API.Message import Wire.API.Team.LegalHold import Wire.API.User.Client @@ -192,8 +192,9 @@ getRemoteClients remoteMembers = where getRemoteClientsFromDomain (qUntagged -> Qualified uids domain) = Map.mapKeys (domain,) . fmap (Set.map pubClientId) . userMap - <$> FederatedBrig.getUserClients FederatedBrig.clientRoutes (FederatedBrig.GetUserClients uids) + <$> getUserClients clientRoutes (GetUserClients uids) +-- FUTUREWORK: sender should be Local UserId postRemoteOtrMessage :: Members '[FederatorAccess] r => Qualified UserId -> @@ -202,13 +203,13 @@ postRemoteOtrMessage :: Sem r (PostOtrResponse MessageSendingStatus) postRemoteOtrMessage sender conv rawMsg = do let msr = - FederatedGalley.MessageSendRequest - { FederatedGalley.msrConvId = tUnqualified conv, - FederatedGalley.msrSender = qUnqualified sender, - FederatedGalley.msrRawMessage = Base64ByteString rawMsg + MessageSendRequest + { msrConvId = tUnqualified conv, + msrSender = qUnqualified sender, + msrRawMessage = Base64ByteString rawMsg } - rpc = FederatedGalley.sendMessage FederatedGalley.clientRoutes (qDomain sender) msr - FederatedGalley.msResponse <$> runFederated conv rpc + rpc = sendMessage clientRoutes msr + msResponse <$> runFederated conv rpc postQualifiedOtrMessage :: Members @@ -397,18 +398,18 @@ sendRemoteMessages domain now sender senderClient lcnv metadata messages = (hand mempty (Map.assocs messages) rm = - FederatedGalley.RemoteMessage - { FederatedGalley.rmTime = now, - FederatedGalley.rmData = mmData metadata, - FederatedGalley.rmSender = sender, - FederatedGalley.rmSenderClient = senderClient, - FederatedGalley.rmConversation = tUnqualified lcnv, - FederatedGalley.rmPriority = mmNativePriority metadata, - FederatedGalley.rmPush = mmNativePush metadata, - FederatedGalley.rmTransient = mmTransient metadata, - FederatedGalley.rmRecipients = UserClientMap rcpts + RemoteMessage + { rmTime = now, + rmData = mmData metadata, + rmSender = sender, + rmSenderClient = senderClient, + rmConversation = tUnqualified lcnv, + rmPriority = mmNativePriority metadata, + rmPush = mmNativePush metadata, + rmTransient = mmTransient metadata, + rmRecipients = UserClientMap rcpts } - let rpc = FederatedGalley.onMessageSent FederatedGalley.clientRoutes (tDomain lcnv) rm + let rpc = onMessageSent clientRoutes rm runFederatedEither domain rpc where handle :: Either FederationError a -> Sem r (Set (UserId, ClientId)) diff --git a/services/galley/src/Galley/API/Query.hs b/services/galley/src/Galley/API/Query.hs index 40e3653ec80..b2c678d8371 100644 --- a/services/galley/src/Galley/API/Query.hs +++ b/services/galley/src/Galley/API/Query.hs @@ -71,9 +71,10 @@ import Wire.API.Conversation (ConversationCoverView (..)) import qualified Wire.API.Conversation as Public import qualified Wire.API.Conversation.Role as Public import Wire.API.ErrorDescription -import Wire.API.Federation.API.Galley (gcresConvs) -import qualified Wire.API.Federation.API.Galley as FederatedGalley -import Wire.API.Federation.Client (FederationError (..)) +import Wire.API.Federation.API +import Wire.API.Federation.API.Galley hiding (getConversations) +import qualified Wire.API.Federation.API.Galley as F +import Wire.API.Federation.Error import qualified Wire.API.Provider.Bot as Public import qualified Wire.API.Routes.MultiTablePaging as Public @@ -203,13 +204,13 @@ getRemoteConversationsWithFailures :: getRemoteConversationsWithFailures lusr convs = do -- get self member statuses from the database statusMap <- E.getRemoteConversationStatus (tUnqualified lusr) convs - let remoteView :: Remote FederatedGalley.RemoteConversation -> Conversation + let remoteView :: Remote RemoteConversation -> Conversation remoteView rconv = Mapping.remoteConversationView lusr ( Map.findWithDefault defMemberStatus - (fmap FederatedGalley.rcnvId rconv) + (fmap rcnvId rconv) statusMap ) rconv @@ -219,18 +220,18 @@ getRemoteConversationsWithFailures lusr convs = do | otherwise = [failedGetConversationLocally (map qUntagged locallyNotFound)] -- request conversations from remote backends - let rpc = FederatedGalley.getConversations FederatedGalley.clientRoutes (tDomain lusr) + let rpc = F.getConversations clientRoutes resp <- E.runFederatedConcurrentlyEither locallyFound $ \someConvs -> - rpc $ FederatedGalley.GetConversationsRequest (tUnqualified lusr) (tUnqualified someConvs) + rpc $ GetConversationsRequest (tUnqualified lusr) (tUnqualified someConvs) bimap (localFailures <>) (map remoteView . concat) . partitionEithers <$> traverse handleFailure resp where handleFailure :: Members '[P.TinyLog] r => - Either (Remote [ConvId], FederationError) (Remote FederatedGalley.GetConversationsResponse) -> - Sem r (Either FailedGetConversation [Remote FederatedGalley.RemoteConversation]) + Either (Remote [ConvId], FederationError) (Remote GetConversationsResponse) -> + Sem r (Either FailedGetConversation [Remote RemoteConversation]) handleFailure (Left (rcids, e)) = do P.warn $ Logger.msg ("Error occurred while fetching remote conversations" :: ByteString) diff --git a/services/galley/src/Galley/API/Teams.hs b/services/galley/src/Galley/API/Teams.hs index ce9b1ef65ba..6c4d104240a 100644 --- a/services/galley/src/Galley/API/Teams.hs +++ b/services/galley/src/Galley/API/Teams.hs @@ -129,7 +129,7 @@ import qualified SAML2.WebSSO as SAML import qualified System.Logger.Class as Log import qualified Wire.API.Conversation.Role as Public import Wire.API.ErrorDescription -import Wire.API.Federation.Client +import Wire.API.Federation.Error import qualified Wire.API.Notification as Public import qualified Wire.API.Team as Public import qualified Wire.API.Team.Conversation as Public diff --git a/services/galley/src/Galley/API/Teams/Features.hs b/services/galley/src/Galley/API/Teams/Features.hs index 19e49f76b1b..3ac5bf52db0 100644 --- a/services/galley/src/Galley/API/Teams/Features.hs +++ b/services/galley/src/Galley/API/Teams/Features.hs @@ -81,7 +81,7 @@ import qualified System.Logger.Class as Log import Wire.API.ErrorDescription import Wire.API.Event.FeatureConfig import qualified Wire.API.Event.FeatureConfig as Event -import Wire.API.Federation.Client +import Wire.API.Federation.Error import Wire.API.Team.Feature (AllFeatureConfigs (..), FeatureHasNoConfig, KnownTeamFeatureName, TeamFeatureName) import qualified Wire.API.Team.Feature as Public diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index 1deea13837c..26af1fabcb2 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -123,8 +123,9 @@ import qualified Wire.API.Conversation.Code as Public import Wire.API.Conversation.Role (roleNameWireAdmin) import Wire.API.ErrorDescription import qualified Wire.API.Event.Conversation as Public -import qualified Wire.API.Federation.API.Galley as FederatedGalley -import Wire.API.Federation.Client +import Wire.API.Federation.API +import Wire.API.Federation.API.Galley +import Wire.API.Federation.Error import qualified Wire.API.Message as Public import Wire.API.Routes.Public.Util (UpdateResult (..)) import Wire.API.ServantProto (RawProto (..)) @@ -1095,24 +1096,20 @@ removeMemberFromRemoteConv :: Sem r (Maybe Event) removeMemberFromRemoteConv cnv lusr victim | qUntagged lusr == victim = do - let lc = FederatedGalley.LeaveConversationRequest (tUnqualified cnv) (qUnqualified victim) - let rpc = - FederatedGalley.leaveConversation - FederatedGalley.clientRoutes - (qDomain victim) - lc - (either handleError handleSuccess =<<) . fmap FederatedGalley.leaveResponse $ + let lc = LeaveConversationRequest (tUnqualified cnv) (qUnqualified victim) + let rpc = leaveConversation clientRoutes lc + (either handleError handleSuccess =<<) . fmap leaveResponse $ E.runFederated cnv rpc | otherwise = throw (ActionDenied RemoveConversationMember) where handleError :: Members '[Error ActionError, Error ConversationError] r => - FederatedGalley.RemoveFromConversationError -> + RemoveFromConversationError -> Sem r (Maybe Event) - handleError FederatedGalley.RemoveFromConversationErrorRemovalNotAllowed = + handleError RemoveFromConversationErrorRemovalNotAllowed = throw (ActionDenied RemoveConversationMember) - handleError FederatedGalley.RemoveFromConversationErrorNotFound = throw ConvNotFound - handleError FederatedGalley.RemoveFromConversationErrorUnchanged = pure Nothing + handleError RemoveFromConversationErrorNotFound = throw ConvNotFound + handleError RemoveFromConversationErrorUnchanged = pure Nothing handleSuccess :: Member (Input UTCTime) r => () -> Sem r (Maybe Event) handleSuccess _ = do diff --git a/services/galley/src/Galley/API/Util.hs b/services/galley/src/Galley/API/Util.hs index 4971c19dc87..607236545eb 100644 --- a/services/galley/src/Galley/API/Util.hs +++ b/services/galley/src/Galley/API/Util.hs @@ -66,8 +66,9 @@ import Polysemy.Error import Polysemy.Input import qualified Wire.API.Conversation as Public import Wire.API.ErrorDescription -import Wire.API.Federation.API.Galley as FederatedGalley -import Wire.API.Federation.Client +import Wire.API.Federation.API +import Wire.API.Federation.API.Galley +import Wire.API.Federation.Error type JSON = Media "application" "json" @@ -734,7 +735,7 @@ registerRemoteConversationMemberships now localDomain c = do let allRemoteMembers = nubOrd (map rmId (Data.convRemoteMembers c)) rc = toNewRemoteConversation now localDomain c runFederatedConcurrently_ allRemoteMembers $ \_ -> - FederatedGalley.onConversationCreated FederatedGalley.clientRoutes localDomain rc + onConversationCreated clientRoutes rc -------------------------------------------------------------------------------- -- Legalhold diff --git a/services/galley/src/Galley/Effects/FederatorAccess.hs b/services/galley/src/Galley/Effects/FederatorAccess.hs index 9aa1db8c315..12cad3a36a3 100644 --- a/services/galley/src/Galley/Effects/FederatorAccess.hs +++ b/services/galley/src/Galley/Effects/FederatorAccess.hs @@ -28,42 +28,41 @@ module Galley.Effects.FederatorAccess where import Data.Qualified -import Galley.Intra.Federator.Types import Imports import Polysemy import Wire.API.Federation.Client -import Wire.API.Federation.GRPC.Types +import Wire.API.Federation.Component +import Wire.API.Federation.Error data FederatorAccess m a where RunFederated :: - forall (c :: Component) a m x. + KnownComponent c => Remote x -> - FederatedRPC c a -> + FederatorClient c a -> FederatorAccess m a RunFederatedEither :: - forall (c :: Component) a m x. + KnownComponent c => Remote x -> - FederatedRPC c a -> + FederatorClient c a -> FederatorAccess m (Either FederationError a) RunFederatedConcurrently :: - forall (c :: Component) f a m x. - (Foldable f, Functor f) => + (KnownComponent c, Foldable f, Functor f) => f (Remote x) -> - (Remote [x] -> FederatedRPC c a) -> + (Remote [x] -> FederatorClient c a) -> FederatorAccess m [Remote a] RunFederatedConcurrentlyEither :: forall (c :: Component) f a m x. - (Foldable f, Functor f) => + (KnownComponent c, Foldable f, Functor f) => f (Remote x) -> - (Remote [x] -> FederatedRPC c a) -> + (Remote [x] -> FederatorClient c a) -> FederatorAccess m [Either (Remote [x], FederationError) (Remote a)] IsFederationConfigured :: FederatorAccess m Bool makeSem ''FederatorAccess runFederatedConcurrently_ :: - (Foldable f, Functor f, Member FederatorAccess r) => + (KnownComponent c, Foldable f, Functor f, Member FederatorAccess r) => f (Remote a) -> - (Remote [a] -> FederatedRPC c ()) -> + (Remote [a] -> FederatorClient c ()) -> Sem r () runFederatedConcurrently_ xs = void . runFederatedConcurrently xs diff --git a/services/galley/src/Galley/Intra/Federator.hs b/services/galley/src/Galley/Intra/Federator.hs index b4bf53c6c26..89af2a90b1d 100644 --- a/services/galley/src/Galley/Intra/Federator.hs +++ b/services/galley/src/Galley/Intra/Federator.hs @@ -19,18 +19,20 @@ module Galley.Intra.Federator (interpretFederatorAccess) where +import Control.Lens import Control.Monad.Except import Data.Bifunctor import Data.Qualified import Galley.Effects.FederatorAccess (FederatorAccess (..)) import Galley.Env -import Galley.Intra.Federator.Types import Galley.Monad +import Galley.Options import Imports import Polysemy import Polysemy.Input import UnliftIO import Wire.API.Federation.Client +import Wire.API.Federation.Component import Wire.API.Federation.Error interpretFederatorAccess :: @@ -44,37 +46,52 @@ interpretFederatorAccess = interpret $ \case RunFederatedConcurrentlyEither rs f -> embedApp $ runFederatedConcurrentlyEither rs f - IsFederationConfigured -> embedApp $ isJust <$> federatorEndpoint + IsFederationConfigured -> embedApp $ isJust <$> view federator runFederatedEither :: + KnownComponent c => Remote x -> - FederatedRPC c a -> + FederatorClient c a -> App (Either FederationError a) runFederatedEither (tDomain -> remoteDomain) rpc = do - env <- ask - liftIO $ runApp env (runExceptT (executeFederated remoteDomain rpc)) + ownDomain <- view (options . optSettings . setFederationDomain) + mfedEndpoint <- view federator + case mfedEndpoint of + Nothing -> pure (Left FederationNotConfigured) + Just fedEndpoint -> do + let ce = + FederatorClientEnv + { ceOriginDomain = ownDomain, + ceTargetDomain = remoteDomain, + ceFederator = fedEndpoint + } + liftIO . fmap (first FederationCallFailure) $ runFederatorClient ce rpc runFederated :: + KnownComponent c => Remote x -> - FederatedRPC c a -> + FederatorClient c a -> App a runFederated dom rpc = runFederatedEither dom rpc >>= either (throwIO . federationErrorToWai) pure runFederatedConcurrently :: - (Foldable f, Functor f) => + ( Foldable f, + Functor f, + KnownComponent c + ) => f (Remote a) -> - (Remote [a] -> FederatedRPC c b) -> + (Remote [a] -> FederatorClient c b) -> App [Remote b] runFederatedConcurrently xs rpc = pooledForConcurrentlyN 8 (bucketRemote xs) $ \r -> qualifyAs r <$> runFederated r (rpc r) runFederatedConcurrentlyEither :: - (Foldable f, Functor f) => + (Foldable f, Functor f, KnownComponent c) => f (Remote a) -> - (Remote [a] -> FederatedRPC c b) -> + (Remote [a] -> FederatorClient c b) -> App [Either (Remote [a], FederationError) (Remote b)] runFederatedConcurrentlyEither xs rpc = pooledForConcurrentlyN 8 (bucketRemote xs) $ \r -> diff --git a/services/galley/src/Galley/Monad.hs b/services/galley/src/Galley/Monad.hs index fe8a19eb9a6..1148a1a0de8 100644 --- a/services/galley/src/Galley/Monad.hs +++ b/services/galley/src/Galley/Monad.hs @@ -26,13 +26,11 @@ import Control.Lens import Control.Monad.Catch import Control.Monad.Except import Galley.Env -import Galley.Options import Imports hiding (log) import Polysemy import Polysemy.Input import System.Logger import qualified System.Logger.Class as LC -import Wire.API.Federation.Client newtype App a = App {unApp :: ReaderT Env IO a} deriving @@ -50,10 +48,6 @@ newtype App a = App {unApp :: ReaderT Env IO a} runApp :: Env -> App a -> IO a runApp env = flip runReaderT env . unApp -instance HasFederatorConfig App where - federatorEndpoint = view federator - federationDomain = view (options . optSettings . setFederationDomain) - instance HasRequestId App where getRequestId = App $ view reqId diff --git a/services/galley/src/Galley/Run.hs b/services/galley/src/Galley/Run.hs index 907bd8c7cbd..b34d7df7243 100644 --- a/services/galley/src/Galley/Run.hs +++ b/services/galley/src/Galley/Run.hs @@ -34,7 +34,7 @@ import Data.Misc (portNumber) import Data.String.Conversions (cs) import Data.Text (unpack) import qualified Galley.API as API -import Galley.API.Federation (federationSitemap) +import Galley.API.Federation (FederationAPI, federationSitemap) import qualified Galley.API.Internal as Internal import Galley.App import qualified Galley.App as App @@ -49,10 +49,8 @@ import qualified Network.Wai.Middleware.Gunzip as GZip import qualified Network.Wai.Middleware.Gzip as GZip import Network.Wai.Utilities.Server import Servant hiding (route) -import Servant.API.Generic (ToServantApi) import qualified System.Logger as Log import Util.Options -import qualified Wire.API.Federation.API.Galley as FederationGalley import qualified Wire.API.Routes.Public.Galley as GalleyAPI run :: Opts -> IO () @@ -104,7 +102,7 @@ mkApp o = do ) ( hoistServer' @GalleyAPI.ServantAPI (toServantHandler e) API.servantSitemap :<|> hoistServer' @Internal.ServantAPI (toServantHandler e) Internal.servantSitemap - :<|> hoistServer' @(ToServantApi FederationGalley.Api) (toServantHandler e) federationSitemap + :<|> hoistServer' @FederationAPI (toServantHandler e) federationSitemap :<|> Servant.Tagged (app e) ) r @@ -144,7 +142,11 @@ bodyParserErrorFormatter' _ _ errMsg = Servant.errHeaders = [(HTTP.hContentType, HTTPMedia.renderHeader (Servant.contentType (Proxy @Servant.JSON)))] } -type CombinedAPI = GalleyAPI.ServantAPI :<|> Internal.ServantAPI :<|> ToServantApi FederationGalley.Api :<|> Servant.Raw +type CombinedAPI = + GalleyAPI.ServantAPI + :<|> Internal.ServantAPI + :<|> FederationAPI + :<|> Servant.Raw refreshMetrics :: App () refreshMetrics = do diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index 945bda76de1..d394a30c025 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -37,15 +37,15 @@ import Bilge hiding (timeout) import Bilge.Assert import Brig.Types import qualified Control.Concurrent.Async as Async +import Control.Exception (throw) import Control.Lens (at, ix, preview, view, (.~), (?~)) import Control.Monad.Except (MonadError (throwError)) import Control.Monad.Trans.Maybe import Data.Aeson hiding (json) import qualified Data.ByteString as BS import Data.ByteString.Conversion -import qualified Data.ByteString.Lazy as LBS import qualified Data.Code as Code -import Data.Domain (Domain (Domain), domainText) +import Data.Domain import Data.Either.Extra (eitherToMaybe) import Data.Id import Data.Json.Util (toBase64Text, toUTCTimeMillis) @@ -61,6 +61,8 @@ import Data.String.Conversions (cs) import qualified Data.Text as T import qualified Data.Text.Ascii as Ascii 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.Types hiding (LocalMember (..)) @@ -70,6 +72,7 @@ import Galley.Types.Conversations.Roles import qualified Galley.Types.Teams as Teams import Gundeck.Types.Notification import Imports +import qualified Network.HTTP.Types as HTTP import Network.Wai.Utilities.Error import Servant (ServerError (errBody), err501, err503) import Servant.Server (Handler) @@ -84,23 +87,13 @@ import TestSetup import Util.Options (Endpoint (Endpoint)) import Wire.API.Conversation import Wire.API.Conversation.Action -import qualified Wire.API.Federation.API.Brig as FederatedBrig +import Wire.API.Federation.API +import qualified Wire.API.Federation.API.Brig as F import Wire.API.Federation.API.Galley - ( Api (onConversationUpdated), - ConversationUpdate (cuAction, cuAlreadyPresentUsers, cuConvId, cuOrigUserId), - GetConversationsResponse (..), - RemoteConvMembers (..), - RemoteConversation (..), - ) -import qualified Wire.API.Federation.API.Galley as FederatedGalley -import qualified Wire.API.Federation.GRPC.Types as F +import qualified Wire.API.Federation.API.Galley as F import qualified Wire.API.Message as Message import Wire.API.Routes.MultiTablePaging import Wire.API.User.Client - ( QualifiedUserClients (..), - UserClientPrekeyMap, - getUserClientPrekeyMap, - ) import Wire.API.UserMap (UserMap (..)) tests :: IO TestSetup -> TestTree @@ -230,34 +223,34 @@ tests s = test s "iUpsertOne2OneConversation" testAllOne2OneConversationRequests ] -emptyFederatedBrig :: FederatedBrig.Api (AsServerT Handler) +emptyFederatedBrig :: F.BrigApi (AsServerT Handler) emptyFederatedBrig = let e :: Text -> Handler a e s = throwError err501 {errBody = cs ("mock not implemented: " <> s)} - in FederatedBrig.Api - { FederatedBrig.getUserByHandle = \_ -> e "getUserByHandle", - FederatedBrig.getUsersByIds = \_ -> e "getUsersByIds", - FederatedBrig.claimPrekey = \_ -> e "claimPrekey", - FederatedBrig.claimPrekeyBundle = \_ -> e "claimPrekeyBundle", - FederatedBrig.claimMultiPrekeyBundle = \_ -> e "claimMultiPrekeyBundle", - FederatedBrig.searchUsers = \_ -> e "searchUsers", - FederatedBrig.getUserClients = \_ -> e "getUserClients", - FederatedBrig.sendConnectionAction = \_ _ -> e "sendConnectionAction", - FederatedBrig.onUserDeleted = \_ _ -> e "onUserDeleted" + in F.BrigApi + { F.getUserByHandle = \_ -> e "getUserByHandle", + F.getUsersByIds = \_ -> e "getUsersByIds", + F.claimPrekey = \_ -> e "claimPrekey", + F.claimPrekeyBundle = \_ -> e "claimPrekeyBundle", + F.claimMultiPrekeyBundle = \_ -> e "claimMultiPrekeyBundle", + F.searchUsers = \_ -> e "searchUsers", + F.getUserClients = \_ -> e "getUserClients", + F.sendConnectionAction = \_ _ -> e "sendConnectionAction", + F.onUserDeleted = \_ _ -> e "onUserDeleted" } -emptyFederatedGalley :: FederatedGalley.Api (AsServerT Handler) +emptyFederatedGalley :: F.GalleyApi (AsServerT Handler) emptyFederatedGalley = let e :: Text -> Handler a e s = throwError err501 {errBody = cs ("mock not implemented: " <> s)} - in FederatedGalley.Api - { FederatedGalley.onConversationCreated = \_ _ -> e "onConversationCreated", - FederatedGalley.getConversations = \_ _ -> e "getConversations", - FederatedGalley.onConversationUpdated = \_ _ -> e "onConversationUpdated", - FederatedGalley.leaveConversation = \_ _ -> e "leaveConversation", - FederatedGalley.onMessageSent = \_ _ -> e "onMessageSent", - FederatedGalley.sendMessage = \_ _ -> e "sendMessage", - FederatedGalley.onUserDeleted = \_ _ -> e "onUserDeleted" + in F.GalleyApi + { F.onConversationCreated = \_ _ -> e "onConversationCreated", + F.getConversations = \_ _ -> e "getConversations", + F.onConversationUpdated = \_ _ -> e "onConversationUpdated", + F.leaveConversation = \_ _ -> e "leaveConversation", + F.onMessageSent = \_ _ -> e "onMessageSent", + F.sendMessage = \_ _ -> e "sendMessage", + F.onUserDeleted = \_ _ -> e "onUserDeleted" } ------------------------------------------------------------------------------- @@ -338,33 +331,27 @@ postConvWithRemoteUsersOk = do cvs <- mapM (convView cid) [alice, alex, amy] liftIO $ mapM_ WS.assertSuccess =<< Async.mapConcurrently (checkWs qAlice) (zip cvs [wsAlice, wsAlex, wsAmy]) - cFedReq <- assertOne $ filter (\r -> F.domain r == domainText cDomain) federatedRequests - cFedReqBody <- assertRight $ parseFedReqBody cFedReq + cFedReq <- assertOne $ filter (\r -> frTargetDomain r == cDomain) federatedRequests + cFedReqBody <- assertRight $ parseFedRequest cFedReq - dFedReq <- assertOne $ filter (\r -> F.domain r == domainText dDomain) federatedRequests - dFedReqBody <- assertRight $ parseFedReqBody dFedReq + dFedReq <- assertOne $ filter (\r -> frTargetDomain r == dDomain) federatedRequests + dFedReqBody <- assertRight $ parseFedRequest dFedReq liftIO $ do length federatedRequests @?= 2 - FederatedGalley.rcOrigUserId cFedReqBody @?= alice - FederatedGalley.rcCnvId cFedReqBody @?= cid - FederatedGalley.rcCnvType cFedReqBody @?= RegularConv - FederatedGalley.rcCnvAccess cFedReqBody @?= [InviteAccess] - FederatedGalley.rcCnvAccessRole cFedReqBody @?= ActivatedAccessRole - FederatedGalley.rcCnvName cFedReqBody @?= Just nameMaxSize - FederatedGalley.rcNonCreatorMembers cFedReqBody @?= Set.fromList (toOtherMember <$> [qAlex, qAmy, qChad, qCharlie, qDee]) - FederatedGalley.rcMessageTimer cFedReqBody @?= Nothing - FederatedGalley.rcReceiptMode cFedReqBody @?= Nothing + F.rcOrigUserId cFedReqBody @?= alice + F.rcCnvId cFedReqBody @?= cid + F.rcCnvType cFedReqBody @?= RegularConv + F.rcCnvAccess cFedReqBody @?= [InviteAccess] + F.rcCnvAccessRole cFedReqBody @?= ActivatedAccessRole + F.rcCnvName cFedReqBody @?= Just nameMaxSize + F.rcNonCreatorMembers cFedReqBody @?= Set.fromList (toOtherMember <$> [qAlex, qAmy, qChad, qCharlie, qDee]) + F.rcMessageTimer cFedReqBody @?= Nothing + F.rcReceiptMode cFedReqBody @?= Nothing dFedReqBody @?= cFedReqBody where - parseFedReqBody :: FromJSON a => F.FederatedRequest -> Either String a - parseFedReqBody fr = - case F.request fr of - Just r -> - (eitherDecode . cs) (F.body r) - Nothing -> Left "No request" toOtherMember qid = OtherMember qid Nothing roleNameWireAdmin convView cnv usr = responseJsonUnsafeWithMsg "conversation" <$> getConv usr cnv checkWs qalice (cnv, ws) = WS.awaitMatch (5 # Second) ws $ \n -> do @@ -640,7 +627,7 @@ postMessageQualifiedLocalOwningBackendSuccess = do let mkPubClient c = PubClient c Nothing brigApi d = emptyFederatedBrig - { FederatedBrig.getUserClients = \_ -> + { F.getUserClients = \_ -> pure $ if | d == bDomain -> @@ -653,7 +640,7 @@ postMessageQualifiedLocalOwningBackendSuccess = do } galleyApi _ = emptyFederatedGalley - { FederatedGalley.onMessageSent = \_ _ -> pure () + { F.onMessageSent = \_ _ -> pure () } (resp2, requests) <- postProteusMessageQualifiedWithMockFederator aliceU aliceClient convId message "data" Message.MismatchReportAll brigApi galleyApi @@ -669,23 +656,23 @@ postMessageQualifiedLocalOwningBackendSuccess = do encodedTextForCarl = toBase64Text "text-for-carl" encodedData = toBase64Text "data" liftIO $ do - let matchReq domain component r = F.domain r == domainText domain && (F.component <$> F.request r) == Just component + let matchReq domain component r = frTargetDomain r == domain && frComponent r == component filterReq domain component = filter (matchReq domain component) requests - bBrigReq <- assertOne $ filterReq bDomain F.Brig - bGalleyReq <- assertOne $ filterReq bDomain F.Galley - cBrigReq <- assertOne $ filterReq cDomain F.Brig - cGalleyReq <- assertOne $ filterReq cDomain F.Galley + bBrigReq <- assertOne $ filterReq bDomain Brig + bGalleyReq <- assertOne $ filterReq bDomain Galley + cBrigReq <- assertOne $ filterReq cDomain Brig + cGalleyReq <- assertOne $ filterReq cDomain Galley - (F.path <$> F.request bBrigReq) @?= Just "/federation/get-user-clients" - (sort . FederatedBrig.gucUsers <$> parseFedRequest bBrigReq) @?= Right (sort $ qUnqualified <$> [bob, bart]) - (F.path <$> F.request cBrigReq) @?= Just "/federation/get-user-clients" - parseFedRequest cBrigReq @?= Right (FederatedBrig.GetUserClients [qUnqualified carl]) + frRPC bBrigReq @?= "get-user-clients" + (sort . F.gucUsers <$> parseFedRequest bBrigReq) @?= Right (sort $ qUnqualified <$> [bob, bart]) + frRPC cBrigReq @?= "get-user-clients" + parseFedRequest cBrigReq @?= Right (F.GetUserClients [qUnqualified carl]) - (F.path <$> F.request bGalleyReq) @?= Just "/federation/on-message-sent" + frRPC bGalleyReq @?= "on-message-sent" bActualNotif <- assertRight $ parseFedRequest bGalleyReq let bExpectedNotif = - FederatedGalley.RemoteMessage - { rmTime = FederatedGalley.rmTime bActualNotif, + F.RemoteMessage + { rmTime = F.rmTime bActualNotif, rmData = Just $ toBase64Text "data", rmSender = alice, rmSenderClient = aliceClient, @@ -706,11 +693,11 @@ postMessageQualifiedLocalOwningBackendSuccess = do ] } bActualNotif @?= bExpectedNotif - (F.path <$> F.request cGalleyReq) @?= Just "/federation/on-message-sent" + frRPC cGalleyReq @?= "on-message-sent" cActualNotif <- assertRight $ parseFedRequest cGalleyReq let cExpectedNotif = bExpectedNotif - { FederatedGalley.rmRecipients = + { F.rmRecipients = UserClientMap $ Map.fromList [(qUnqualified carl, Map.singleton carlClient encodedTextForCarl)] } cActualNotif @?= cExpectedNotif @@ -759,7 +746,7 @@ postMessageQualifiedLocalOwningBackendMissingClients = do WS.bracketR2 cannon bobUnqualified chadUnqualified $ \(wsBob, wsChad) -> do let brigApi _ = emptyFederatedBrig - { FederatedBrig.getUserClients = \_ -> + { F.getUserClients = \_ -> pure $ UserMap (Map.singleton (qUnqualified deeRemote) (Set.singleton (PubClient deeClient Nothing))) } galleyApi _ = emptyFederatedGalley @@ -836,16 +823,16 @@ postMessageQualifiedLocalOwningBackendRedundantAndDeletedClients = do -- FUTUREWORK: Mock federator and ensure that a message to Dee is sent let brigApi _ = emptyFederatedBrig - { FederatedBrig.getUserClients = \getUserClients -> + { F.getUserClients = \getUserClients -> let lookupClients uid | uid == deeRemoteUnqualified = Just (uid, Set.fromList [PubClient deeClient Nothing]) | uid == nonMemberRemoteUnqualified = Just (uid, Set.fromList [PubClient nonMemberRemoteClient Nothing]) | otherwise = Nothing - in pure $ UserMap . Map.fromList . mapMaybe lookupClients $ FederatedBrig.gucUsers getUserClients + in pure $ UserMap . Map.fromList . mapMaybe lookupClients $ F.gucUsers getUserClients } galleyApi _ = emptyFederatedGalley - { FederatedGalley.onMessageSent = \_ _ -> pure () + { F.onMessageSent = \_ _ -> pure () } (resp2, _requests) <- postProteusMessageQualifiedWithMockFederator aliceUnqualified aliceClient convId message "data" Message.MismatchReportAll brigApi galleyApi @@ -916,7 +903,7 @@ postMessageQualifiedLocalOwningBackendIgnoreMissingClients = do let brigApi _ = emptyFederatedBrig - { FederatedBrig.getUserClients = \_ -> pure $ UserMap (Map.singleton (qUnqualified deeRemote) (Set.singleton (PubClient deeClient Nothing))) + { F.getUserClients = \_ -> pure $ UserMap (Map.singleton (qUnqualified deeRemote) (Set.singleton (PubClient deeClient Nothing))) } galleyApi _ = emptyFederatedGalley @@ -1049,12 +1036,12 @@ postMessageQualifiedLocalOwningBackendFailedToSendClients = do let brigApi _ = emptyFederatedBrig - { FederatedBrig.getUserClients = \_ -> + { F.getUserClients = \_ -> pure $ UserMap (Map.singleton (qUnqualified deeRemote) (Set.singleton (PubClient deeClient Nothing))) } galleyApi _ = emptyFederatedGalley - { FederatedGalley.onMessageSent = \_ _ -> throwError err503 {errBody = "Down for maintenance."} + { F.onMessageSent = \_ _ -> throwError err503 {errBody = "Down for maintenance."} } (resp2, _requests) <- postProteusMessageQualifiedWithMockFederator aliceUnqualified aliceClient convId message "data" Message.MismatchReportAll brigApi galleyApi @@ -1088,14 +1075,14 @@ postMessageQualifiedRemoteOwningBackendFailure = do let galleyApi _ = emptyFederatedGalley - { FederatedGalley.sendMessage = \_ _ -> throwError err503 {errBody = "Down for maintenance."} + { F.sendMessage = \_ _ -> throwError err503 {errBody = "Down for maintenance."} } (resp2, _requests) <- postProteusMessageQualifiedWithMockFederator aliceUnqualified aliceClient convId [] "data" Message.MismatchReportAll (const emptyFederatedBrig) galleyApi pure resp2 !!! do - const 533 === statusCode + const 503 === statusCode postMessageQualifiedRemoteOwningBackendSuccess :: TestM () postMessageQualifiedRemoteOwningBackendSuccess = do @@ -1128,7 +1115,7 @@ postMessageQualifiedRemoteOwningBackendSuccess = do message = [(bobOwningDomain, bobClient, "text-for-bob"), (deeRemote, deeClient, "text-for-dee")] galleyApi _ = emptyFederatedGalley - { FederatedGalley.sendMessage = \_ _ -> pure (FederatedGalley.MessageSendResponse (Right mss)) + { F.sendMessage = \_ _ -> pure (F.MessageSendResponse (Right mss)) } (resp2, _requests) <- @@ -1348,13 +1335,12 @@ testAccessUpdateGuestRemoved = do -- dee's remote receives a notification liftIO . assertBool "remote users are not notified" . isJust . flip find reqs $ \freq -> - let req = F.request freq - in and - [ fmap F.component req == Just F.Galley, - fmap F.path req == Just "/federation/on-conversation-updated", - fmap (fmap FederatedGalley.cuAction . eitherDecode . LBS.fromStrict . F.body) req - == Just (Right (ConversationActionRemoveMembers (charlie :| [dee]))) - ] + and + [ frComponent freq == Galley, + frRPC freq == "on-conversation-updated", + fmap F.cuAction (eitherDecode (frBody freq)) + == Right (ConversationActionRemoveMembers (charlie :| [dee])) + ] -- only alice and bob remain conv2 <- @@ -1497,14 +1483,14 @@ paginateConvListIds = do replicateM_ 25 $ do conv <- randomId let cu = - FederatedGalley.ConversationUpdate - { FederatedGalley.cuTime = now, - FederatedGalley.cuOrigUserId = qChad, - FederatedGalley.cuConvId = conv, - FederatedGalley.cuAlreadyPresentUsers = [], - FederatedGalley.cuAction = ConversationActionAddMembers (pure qAlice) roleNameWireMember + F.ConversationUpdate + { F.cuTime = now, + F.cuOrigUserId = qChad, + F.cuConvId = conv, + F.cuAlreadyPresentUsers = [], + F.cuAction = ConversationActionAddMembers (pure qAlice) roleNameWireMember } - FederatedGalley.onConversationUpdated fedGalleyClient chadDomain cu + F.onConversationUpdated (fedGalleyClient chadDomain) cu remoteDee <- randomId let deeDomain = Domain "dee.example.com" @@ -1513,14 +1499,14 @@ paginateConvListIds = do replicateM_ 31 $ do conv <- randomId let cu = - FederatedGalley.ConversationUpdate - { FederatedGalley.cuTime = now, - FederatedGalley.cuOrigUserId = qDee, - FederatedGalley.cuConvId = conv, - FederatedGalley.cuAlreadyPresentUsers = [], - FederatedGalley.cuAction = ConversationActionAddMembers (pure qAlice) roleNameWireMember + F.ConversationUpdate + { F.cuTime = now, + F.cuOrigUserId = qDee, + F.cuConvId = conv, + F.cuAlreadyPresentUsers = [], + F.cuAction = ConversationActionAddMembers (pure qAlice) roleNameWireMember } - FederatedGalley.onConversationUpdated fedGalleyClient deeDomain cu + F.onConversationUpdated (fedGalleyClient deeDomain) cu -- 1 self conv + 2 convs with bob and eve + 197 local convs + 25 convs on -- chad.example.com + 31 on dee.example = 256 convs. Getting them 16 at a time @@ -1558,14 +1544,14 @@ paginateConvListIdsPageEndingAtLocalsAndDomain = do replicateM_ 16 $ do conv <- randomId let cu = - FederatedGalley.ConversationUpdate - { FederatedGalley.cuTime = now, - FederatedGalley.cuOrigUserId = qChad, - FederatedGalley.cuConvId = conv, - FederatedGalley.cuAlreadyPresentUsers = [], - FederatedGalley.cuAction = ConversationActionAddMembers (pure qAlice) roleNameWireMember + F.ConversationUpdate + { F.cuTime = now, + F.cuOrigUserId = qChad, + F.cuConvId = conv, + F.cuAlreadyPresentUsers = [], + F.cuAction = ConversationActionAddMembers (pure qAlice) roleNameWireMember } - FederatedGalley.onConversationUpdated fedGalleyClient chadDomain cu + F.onConversationUpdated (fedGalleyClient chadDomain) cu remoteDee <- randomId let deeDomain = Domain "dee.example.com" @@ -1576,14 +1562,14 @@ paginateConvListIdsPageEndingAtLocalsAndDomain = do replicateM_ 16 $ do conv <- randomId let cu = - FederatedGalley.ConversationUpdate - { FederatedGalley.cuTime = now, - FederatedGalley.cuOrigUserId = qDee, - FederatedGalley.cuConvId = conv, - FederatedGalley.cuAlreadyPresentUsers = [], - FederatedGalley.cuAction = ConversationActionAddMembers (pure qAlice) roleNameWireMember + F.ConversationUpdate + { F.cuTime = now, + F.cuOrigUserId = qDee, + F.cuConvId = conv, + F.cuAlreadyPresentUsers = [], + F.cuAction = ConversationActionAddMembers (pure qAlice) roleNameWireMember } - FederatedGalley.onConversationUpdated fedGalleyClient deeDomain cu + F.onConversationUpdated (fedGalleyClient deeDomain) cu foldM_ (getChunkedConvs 16 0 alice) Nothing [4, 3, 2, 1, 0 :: Int] @@ -2026,9 +2012,8 @@ testAddRemoteMember = do postQualifiedMembers alice (remoteBob :| []) convId F.FederatedRequest -> Value + respond :: Qualified UserId -> FederatedRequest -> Value respond bob req - | fmap F.component (F.request req) == Just F.Brig = + | frComponent req == Brig = toJSON [mkProfile bob (Name "bob")] | otherwise = toJSON () @@ -2252,11 +2237,11 @@ testBulkGetQualifiedConvs = do (respAll, receivedRequests) <- withTempMockFederator' ( \fedReq -> do - let success = pure . F.OutwardResponseBody . LBS.toStrict . encode - case F.domain fedReq of - d | d == domainText remoteDomainA -> success $ GetConversationsResponse [mockConversationA] - d | d == domainText remoteDomainB -> success $ GetConversationsResponse [mockConversationB] - d | d == domainText remoteDomainC -> pure . F.OutwardResponseError $ F.OutwardError F.DiscoveryFailed "discovery failed" + let success = pure . encode + case frTargetDomain fedReq of + d | d == remoteDomainA -> success $ GetConversationsResponse [mockConversationA] + d | d == remoteDomainB -> success $ GetConversationsResponse [mockConversationB] + d | d == remoteDomainC -> throw (DiscoveryFailureSrvNotAvailable "domainC") _ -> assertFailure $ "Unrecognized domain: " <> show fedReq ) (listConvs alice req) @@ -2274,10 +2259,10 @@ testBulkGetQualifiedConvs = do -- Assumes only one request is made let requestedConvIdsA = - fmap FederatedGalley.gcrConvIds - . decode @FederatedGalley.GetConversationsRequest - =<< fmap (LBS.fromStrict . F.body) . F.request - =<< find ((== domainText remoteDomainA) . F.domain) receivedRequests + fmap F.gcrConvIds + . (decode =<<) + . fmap frBody + $ find ((== remoteDomainA) . frTargetDomain) receivedRequests assertEqual "only locally found conversations should be queried" (Just [qUnqualified remoteConvIdA]) requestedConvIdsA let expectedNotFound = sort [localConvIdNotFound, localConvIdNotParticipating, remoteConvIdALocallyNotFound, remoteConvIdBNotFoundOnRemote] @@ -2506,7 +2491,7 @@ deleteLocalMemberConvLocalQualifiedOk = do (respDel, fedRequests) <- withTempMockFederator mockReturnEve $ deleteMemberQualified alice qBob qconvId - let [galleyFederatedRequest] = fedRequestsForDomain remoteDomain F.Galley fedRequests + let [galleyFederatedRequest] = fedRequestsForDomain remoteDomain Galley fedRequests assertRemoveUpdate galleyFederatedRequest qconvId qAlice [qUnqualified qEve] qBob liftIO $ do @@ -2540,15 +2525,15 @@ deleteRemoteMemberConvLocalQualifiedOk = do mapM_ (connectWithRemoteUser alice) [qChad, qDee, qEve] let mockedResponse fedReq = do - let success :: ToJSON a => a -> IO F.OutwardResponse - success = pure . F.OutwardResponseBody . LBS.toStrict . encode - getUsersPath = Just "/federation/get-users-by-ids" - case (F.domain fedReq, F.path <$> F.request fedReq) of + let success :: ToJSON a => a -> IO LByteString + success = pure . encode + getUsersRPC = "get-users-by-ids" + case (frTargetDomain fedReq, frRPC fedReq) of (d, mp) - | d == domainText remoteDomain1 && mp == getUsersPath -> + | d == remoteDomain1 && mp == getUsersRPC -> success [mkProfile qChad (Name "Chad"), mkProfile qDee (Name "Dee")] (d, mp) - | d == domainText remoteDomain2 && mp == getUsersPath -> + | d == remoteDomain2 && mp == getUsersRPC -> success [mkProfile qEve (Name "Eve")] _ -> success () @@ -2570,8 +2555,8 @@ deleteRemoteMemberConvLocalQualifiedOk = do Left err -> assertFailure err Right e -> assertLeaveEvent qconvId qAlice [qChad] e - let [remote1GalleyFederatedRequest] = fedRequestsForDomain remoteDomain1 F.Galley federatedRequests - [remote2GalleyFederatedRequest] = fedRequestsForDomain remoteDomain2 F.Galley federatedRequests + let [remote1GalleyFederatedRequest] = fedRequestsForDomain remoteDomain1 Galley federatedRequests + [remote2GalleyFederatedRequest] = fedRequestsForDomain remoteDomain2 Galley federatedRequests assertRemoveUpdate remote1GalleyFederatedRequest qconvId qAlice [qUnqualified qChad, qUnqualified qDee] qChad assertRemoveUpdate remote2GalleyFederatedRequest qconvId qAlice [qUnqualified qEve] qChad @@ -2594,10 +2579,10 @@ leaveRemoteConvQualifiedOk = do let remoteDomain = Domain "faraway.example.com" qconv = Qualified conv remoteDomain qBob = Qualified bob remoteDomain - let mockedFederatedGalleyResponse :: F.FederatedRequest -> Maybe Value + let mockedFederatedGalleyResponse :: FederatedRequest -> Maybe Value mockedFederatedGalleyResponse req - | fmap F.component (F.request req) == Just F.Galley = - Just . toJSON . FederatedGalley.LeaveConversationResponse . Right $ () + | frComponent req == Galley = + Just . toJSON . F.LeaveConversationResponse . Right $ () | otherwise = Nothing mockResponses = joinMockedFederatedResponses @@ -2608,15 +2593,15 @@ leaveRemoteConvQualifiedOk = do withTempMockFederator mockResponses $ deleteMemberQualified alice qAlice qconv let leaveRequest = - fromJust . decodeStrict . F.body . fromJust . F.request . Imports.head $ + fromJust . decode . frBody . Imports.head $ fedRequests liftIO $ do statusCode resp @?= 200 case responseJsonEither resp of Left err -> assertFailure err Right e -> assertLeaveEvent qconv qAlice [qAlice] e - FederatedGalley.lcConvId leaveRequest @?= conv - FederatedGalley.lcLeaver leaveRequest @?= alice + F.lcConvId leaveRequest @?= conv + F.lcLeaver leaveRequest @?= alice -- Alice tries to leave a non-existent remote conversation leaveNonExistentRemoteConv :: TestM () @@ -2625,11 +2610,11 @@ leaveNonExistentRemoteConv = do let remoteDomain = Domain "faraway.example.com" conv <- randomQualifiedId remoteDomain - let mockResponses :: F.FederatedRequest -> Maybe Value + let mockResponses :: FederatedRequest -> Maybe Value mockResponses req - | fmap F.component (F.request req) == Just F.Galley = - Just . toJSON . FederatedGalley.LeaveConversationResponse $ - Left FederatedGalley.RemoveFromConversationErrorNotFound + | frComponent req == Galley = + Just . toJSON . F.LeaveConversationResponse $ + Left F.RemoveFromConversationErrorNotFound | otherwise = Nothing (resp, fedRequests) <- @@ -2637,12 +2622,12 @@ leaveNonExistentRemoteConv = do responseJsonError =<< deleteMemberQualified (qUnqualified alice) alice conv Maybe Value + let mockResponses :: FederatedRequest -> Maybe Value mockResponses req - | fmap F.component (F.request req) == Just F.Galley = - Just . toJSON . FederatedGalley.LeaveConversationResponse $ - Left FederatedGalley.RemoveFromConversationErrorRemovalNotAllowed + | frComponent req == Galley = + Just . toJSON . F.LeaveConversationResponse $ + Left F.RemoveFromConversationErrorRemovalNotAllowed | otherwise = Nothing (resp, fedRequests) <- @@ -2663,12 +2648,12 @@ leaveRemoteConvDenied = do responseJsonError =<< deleteMemberQualified (qUnqualified alice) alice conv do let e = List1.head (WS.unpackPayload n) @@ -3028,7 +3013,7 @@ putRemoteConvMemberOk update = do fedGalleyClient <- view tsFedGalleyClient now <- liftIO getCurrentTime let cu = - FederatedGalley.ConversationUpdate + F.ConversationUpdate { cuTime = now, cuOrigUserId = qbob, cuConvId = qUnqualified qconv, @@ -3036,7 +3021,7 @@ putRemoteConvMemberOk update = do cuAction = ConversationActionAddMembers (pure qalice) roleNameWireMember } - FederatedGalley.onConversationUpdated fedGalleyClient remoteDomain cu + F.onConversationUpdated (fedGalleyClient remoteDomain) cu -- Expected member state let memberAlice = @@ -3167,12 +3152,12 @@ putReceiptModeWithRemotesOk = do req <- assertOne requests liftIO $ do - F.domain req @?= domainText remoteDomain - fmap F.component (F.request req) @?= Just F.Galley - fmap F.path (F.request req) @?= Just "/federation/on-conversation-updated" - Just (Right cu) <- pure $ fmap (eitherDecode . LBS.fromStrict . F.body) (F.request req) - FederatedGalley.cuConvId cu @?= qUnqualified qconv - FederatedGalley.cuAction cu + frTargetDomain req @?= remoteDomain + frComponent req @?= Galley + frRPC req @?= "on-conversation-updated" + Right cu <- pure . eitherDecode . frBody $ req + F.cuConvId cu @?= qUnqualified qconv + F.cuAction cu @?= ConversationActionReceiptModeUpdate (ConversationReceiptModeUpdate (ReceiptMode 43)) @@ -3287,43 +3272,34 @@ removeUser = do now <- liftIO getCurrentTime fedGalleyClient <- view tsFedGalleyClient let nc cid creator quids = - FederatedGalley.NewRemoteConversation - { FederatedGalley.rcTime = now, - FederatedGalley.rcOrigUserId = qUnqualified creator, - FederatedGalley.rcCnvId = cid, - FederatedGalley.rcCnvType = RegularConv, - FederatedGalley.rcCnvAccess = [], - FederatedGalley.rcCnvAccessRole = PrivateAccessRole, - FederatedGalley.rcCnvName = Just "gossip4", - FederatedGalley.rcNonCreatorMembers = Set.fromList $ createOtherMember <$> quids, - FederatedGalley.rcMessageTimer = Nothing, - FederatedGalley.rcReceiptMode = Nothing + F.NewRemoteConversation + { F.rcTime = now, + F.rcOrigUserId = qUnqualified creator, + F.rcCnvId = cid, + F.rcCnvType = RegularConv, + F.rcCnvAccess = [], + F.rcCnvAccessRole = PrivateAccessRole, + F.rcCnvName = Just "gossip4", + F.rcNonCreatorMembers = Set.fromList $ createOtherMember <$> quids, + F.rcMessageTimer = Nothing, + F.rcReceiptMode = Nothing } - FederatedGalley.onConversationCreated fedGalleyClient bDomain $ nc convB1 bart [alice, alexDel] - FederatedGalley.onConversationCreated fedGalleyClient bDomain $ nc convB2 bart [alexDel] - FederatedGalley.onConversationCreated fedGalleyClient cDomain $ nc convC1 carl [alexDel] - FederatedGalley.onConversationCreated fedGalleyClient dDomain $ nc convD1 dory [alexDel] + F.onConversationCreated (fedGalleyClient bDomain) $ nc convB1 bart [alice, alexDel] + F.onConversationCreated (fedGalleyClient bDomain) $ nc convB2 bart [alexDel] + F.onConversationCreated (fedGalleyClient cDomain) $ nc convC1 carl [alexDel] + F.onConversationCreated (fedGalleyClient dDomain) $ nc convD1 dory [alexDel] WS.bracketR3 c alice' alexDel' amy' $ \(wsAlice, wsAlexDel, wsAmy) -> do - let handler :: F.FederatedRequest -> IO F.OutwardResponse - handler freq@(Domain . F.domain -> domain) - | domain == dDomain = - pure - ( F.OutwardResponseError - ( F.OutwardError - F.ConnectionRefused - "mocked: dDomain is unavailable" - ) - ) - | domain `elem` [bDomain, cDomain] = - case F.path <$> F.request freq of - (Just "/federation/leave-conversation") -> - pure (F.OutwardResponseBody (cs (encode (FederatedGalley.LeaveConversationResponse (Right ()))))) - (Just "federation/on-conversation-updated") -> - pure (F.OutwardResponseBody (cs (encode ()))) - other -> error $ "unmocked path " <> show other - | otherwise = error "unmocked domain" - + let handler :: FederatedRequest -> IO LByteString + handler freq + | frTargetDomain freq == dDomain = + throw $ DiscoveryFailureSrvNotAvailable "dDomain" + | frTargetDomain freq `elem` [bDomain, cDomain] = + case frRPC freq of + "leave-conversation" -> pure (encode (F.LeaveConversationResponse (Right ()))) + "on-conversation-updated" -> pure (encode ()) + _ -> throw $ MockErrorResponse HTTP.status404 "invalid rpc" + | otherwise = throw $ MockErrorResponse HTTP.status500 "unmocked domain" (_, fedRequests) <- withTempMockFederator' handler $ deleteUser alexDel' !!! const 200 === statusCode @@ -3332,28 +3308,28 @@ removeUser = do assertEqual ("expect exactly 7 federated requests in : " <> show fedRequests) 7 (length fedRequests) liftIO $ do - bReq <- assertOne $ filter (matchFedRequest bDomain "/federation/on-user-deleted/conversations") fedRequests - fmap F.component (F.request bReq) @?= Just F.Galley - fmap F.path (F.request bReq) @?= Just "/federation/on-user-deleted/conversations" - Just (Right udcnB) <- pure $ fmap (eitherDecode . LBS.fromStrict . F.body) (F.request bReq) - sort (fromRange (FederatedGalley.udcnConversations udcnB)) @?= sort [convB1, convB2] - FederatedGalley.udcnUser udcnB @?= qUnqualified alexDel + bReq <- assertOne $ filter (matchFedRequest bDomain "on-user-deleted-conversations") fedRequests + frComponent bReq @?= Galley + frRPC bReq @?= "on-user-deleted-conversations" + Right udcnB <- pure . eitherDecode . frBody $ bReq + sort (fromRange (F.udcvConversations udcnB)) @?= sort [convB1, convB2] + F.udcvUser udcnB @?= qUnqualified alexDel liftIO $ do - cReq <- assertOne $ filter (matchFedRequest cDomain "/federation/on-user-deleted/conversations") fedRequests - fmap F.component (F.request cReq) @?= Just F.Galley - fmap F.path (F.request cReq) @?= Just "/federation/on-user-deleted/conversations" - Just (Right udcnC) <- pure $ fmap (eitherDecode . LBS.fromStrict . F.body) (F.request cReq) - sort (fromRange (FederatedGalley.udcnConversations udcnC)) @?= sort [convC1] - FederatedGalley.udcnUser udcnC @?= qUnqualified alexDel + cReq <- assertOne $ filter (matchFedRequest cDomain "on-user-deleted-conversations") fedRequests + frComponent cReq @?= Galley + frRPC cReq @?= "on-user-deleted-conversations" + Right udcnC <- pure . eitherDecode . frBody $ cReq + sort (fromRange (F.udcvConversations udcnC)) @?= sort [convC1] + F.udcvUser udcnC @?= qUnqualified alexDel liftIO $ do - dReq <- assertOne $ filter (matchFedRequest dDomain "/federation/on-user-deleted/conversations") fedRequests - fmap F.component (F.request dReq) @?= Just F.Galley - fmap F.path (F.request dReq) @?= Just "/federation/on-user-deleted/conversations" - Just (Right udcnD) <- pure $ fmap (eitherDecode . LBS.fromStrict . F.body) (F.request dReq) - sort (fromRange (FederatedGalley.udcnConversations udcnD)) @?= sort [convD1] - FederatedGalley.udcnUser udcnD @?= qUnqualified alexDel + dReq <- assertOne $ filter (matchFedRequest dDomain "on-user-deleted-conversations") fedRequests + frComponent dReq @?= Galley + frRPC dReq @?= "on-user-deleted-conversations" + Right udcnD <- pure . eitherDecode . frBody $ dReq + sort (fromRange (F.udcvConversations udcnD)) @?= sort [convD1] + F.udcvUser udcnD @?= qUnqualified alexDel liftIO $ do WS.assertMatchN_ (5 # Second) [wsAlice, wsAlexDel] $ @@ -3362,9 +3338,8 @@ removeUser = do wsAssertMembersLeave qconvA2 alexDel [alexDel] liftIO $ do - let bConvUpdateRPCs = filter (matchFedRequest bDomain "/federation/on-conversation-updated") fedRequests - bConvUpdatesEither :: [Either String ConversationUpdate] <- eitherDecode . LBS.fromStrict . F.body <$$> mapM (assertJust . F.request) bConvUpdateRPCs - bConvUpdates <- mapM assertRight bConvUpdatesEither + let bConvUpdateRPCs = filter (matchFedRequest bDomain "on-conversation-updated") fedRequests + bConvUpdates <- mapM (assertRight . eitherDecode . frBody) bConvUpdateRPCs bConvUpdatesA2 <- assertOne $ filter (\cu -> cuConvId cu == convA2) bConvUpdates cuAction bConvUpdatesA2 @?= ConversationActionRemoveMembers (pure alexDel) @@ -3375,15 +3350,15 @@ removeUser = do cuAlreadyPresentUsers bConvUpdatesA4 @?= [qUnqualified bart] liftIO $ do - cConvUpdateRPC <- assertOne $ filter (matchFedRequest cDomain "/federation/on-conversation-updated") fedRequests - Just (Right convUpdate) <- pure $ fmap (eitherDecode . LBS.fromStrict . F.body) (F.request cConvUpdateRPC) + cConvUpdateRPC <- assertOne $ filter (matchFedRequest cDomain "on-conversation-updated") fedRequests + Right convUpdate <- pure . eitherDecode . frBody $ cConvUpdateRPC cuConvId convUpdate @?= convA4 cuAction convUpdate @?= ConversationActionRemoveMembers (pure alexDel) cuAlreadyPresentUsers convUpdate @?= [qUnqualified carl] liftIO $ do - dConvUpdateRPC <- assertOne $ filter (matchFedRequest dDomain "/federation/on-conversation-updated") fedRequests - Just (Right convUpdate) <- pure $ fmap (eitherDecode . LBS.fromStrict . F.body) (F.request dConvUpdateRPC) + dConvUpdateRPC <- assertOne $ filter (matchFedRequest dDomain "on-conversation-updated") fedRequests + Right convUpdate <- pure . eitherDecode . frBody $ dConvUpdateRPC cuConvId convUpdate @?= convA2 cuAction convUpdate @?= ConversationActionRemoveMembers (pure alexDel) cuAlreadyPresentUsers convUpdate @?= [qUnqualified dwight] @@ -3442,12 +3417,11 @@ testOne2OneConversationRequest shouldBeLocal actor desired = do RemoteActor -> do fedGalleyClient <- view tsFedGalleyClient GetConversationsResponse convs <- - FederatedGalley.getConversations - fedGalleyClient - (tDomain bob) - FederatedGalley.GetConversationsRequest - { FederatedGalley.gcrUserId = tUnqualified bob, - FederatedGalley.gcrConvIds = [qUnqualified convId] + F.getConversations + (fedGalleyClient (tDomain bob)) + F.GetConversationsRequest + { F.gcrUserId = tUnqualified bob, + F.gcrConvIds = [qUnqualified convId] } pure . fmap (map omQualifiedId . rcmOthers . rcnvMembers) @@ -3460,7 +3434,7 @@ testOne2OneConversationRequest shouldBeLocal actor desired = do found <- do let rconv = mkConv (qUnqualified convId) (tUnqualified bob) roleNameWireAdmin [] (resp, _) <- - withTempMockFederator (const (FederatedGalley.GetConversationsResponse [rconv])) $ + withTempMockFederator (const (F.GetConversationsResponse [rconv])) $ getConvQualified (tUnqualified alice) convId pure $ statusCode resp == 200 liftIO $ found @?= ((actor, desired) == (LocalActor, Included)) diff --git a/services/galley/test/integration/API/Federation.hs b/services/galley/test/integration/API/Federation.hs index 877a9afb223..6dd267d9b8d 100644 --- a/services/galley/test/integration/API/Federation.hs +++ b/services/galley/test/integration/API/Federation.hs @@ -41,6 +41,7 @@ import Data.String.Conversions import Data.Time.Clock import Data.Timeout (TimeoutUnit (..), (#)) import Data.UUID.V4 (nextRandom) +import Federator.MockServer (FederatedRequest (..)) import Galley.Types import Galley.Types.Conversations.Intra import Gundeck.Types.Notification @@ -57,7 +58,7 @@ import Wire.API.Conversation.Role import Wire.API.Federation.API.Common import Wire.API.Federation.API.Galley (GetConversationsRequest (..), GetConversationsResponse (..), RemoteConvMembers (..), RemoteConversation (..)) import qualified Wire.API.Federation.API.Galley as FedGalley -import qualified Wire.API.Federation.GRPC.Types as F +import Wire.API.Federation.Component import Wire.API.Message (ClientMismatchStrategy (..), MessageSendingStatus (mssDeletedClients, mssFailedToSend, mssRedundantClients), mkQualifiedOtrPayload, mssMissingClients) import Wire.API.User.Client (PubClient (..)) import Wire.API.User.Profile @@ -85,7 +86,7 @@ tests s = test s "POST /federation/leave-conversation : Invalid type" leaveConversationInvalidType, test s "POST /federation/on-message-sent : Receive a message from another backend" onMessageSent, test s "POST /federation/send-message : Post a message sent from another backend" sendMessage, - test s "POST /federation/on-user-deleted/conversations : Remove deleted remote user from local conversations" onUserDeleted + test s "POST /federation/on-user-deleted-conversations : Remove deleted remote user from local conversations" onUserDeleted ] getConversationsAllFound :: TestM () @@ -130,10 +131,10 @@ getConversationsAllFound = do -- get conversations fedGalleyClient <- view tsFedGalleyClient + GetConversationsResponse convs <- FedGalley.getConversations - fedGalleyClient - (qDomain aliceQ) + (fedGalleyClient (qDomain aliceQ)) ( GetConversationsRequest (qUnqualified aliceQ) (map qUnqualified [cnv1Id, cnvQualifiedId cnv2]) @@ -171,8 +172,7 @@ getConversationsNotPartOf = do rando <- Id <$> liftIO nextRandom GetConversationsResponse convs <- FedGalley.getConversations - fedGalleyClient - localDomain + (fedGalleyClient localDomain) (GetConversationsRequest rando [qUnqualified . cnvQualifiedId $ cnv1]) liftIO $ assertEqual "conversation list not empty" [] convs @@ -235,7 +235,7 @@ addLocalUser = do ConversationActionAddMembers (qalice :| [qdee]) roleNameWireMember } WS.bracketRN c [alice, charlie, dee] $ \[wsA, wsC, wsD] -> do - FedGalley.onConversationUpdated fedGalleyClient remoteDomain cu + FedGalley.onConversationUpdated (fedGalleyClient remoteDomain) cu liftIO $ do WS.assertMatch_ (5 # Second) wsA $ wsAssertMemberJoinWithRole qconv qbob [qalice] roleNameWireMember @@ -289,7 +289,7 @@ addUnconnectedUsersOnly = do ConversationActionAddMembers (qCharlie :| []) roleNameWireMember } -- Alice receives no notifications from this - FedGalley.onConversationUpdated fedGalleyClient remoteDomain cu + FedGalley.onConversationUpdated (fedGalleyClient remoteDomain) cu WS.assertNoEvent (5 # Second) [wsA] -- | This test invokes the federation endpoint: @@ -334,9 +334,9 @@ removeLocalUser = do connectWithRemoteUser alice qBob WS.bracketR c alice $ \ws -> do - FedGalley.onConversationUpdated fedGalleyClient remoteDomain cuAdd + FedGalley.onConversationUpdated (fedGalleyClient remoteDomain) cuAdd afterAddition <- listRemoteConvs remoteDomain alice - FedGalley.onConversationUpdated fedGalleyClient remoteDomain cuRemove + FedGalley.onConversationUpdated (fedGalleyClient remoteDomain) cuRemove liftIO $ do void . WS.assertMatch (3 # Second) ws $ wsAssertMemberJoinWithRole qconv qBob [qAlice] roleNameWireMember @@ -397,21 +397,21 @@ removeRemoteUser = do } WS.bracketRN c [alice, charlie, dee, flo] $ \[wsA, wsC, wsD, wsF] -> do - FedGalley.onConversationUpdated fedGalleyClient remoteDomain (cuRemove qEve) + FedGalley.onConversationUpdated (fedGalleyClient remoteDomain) (cuRemove qEve) liftIO $ do WS.assertMatchN_ (3 # Second) [wsA, wsD] $ wsAssertMembersLeave qconv qBob [qEve] WS.assertNoEvent (1 # Second) [wsC, wsF] WS.bracketRN c [alice, charlie, dee, flo] $ \[wsA, wsC, wsD, wsF] -> do - FedGalley.onConversationUpdated fedGalleyClient remoteDomain (cuRemove qDee) + FedGalley.onConversationUpdated (fedGalleyClient remoteDomain) (cuRemove qDee) liftIO $ do WS.assertMatchN_ (3 # Second) [wsA, wsD] $ wsAssertMembersLeave qconv qBob [qDee] WS.assertNoEvent (1 # Second) [wsC, wsF] WS.bracketRN c [alice, charlie, dee, flo] $ \[wsA, wsC, wsD, wsF] -> do - FedGalley.onConversationUpdated fedGalleyClient remoteDomain (cuRemove qFlo) + FedGalley.onConversationUpdated (fedGalleyClient remoteDomain) (cuRemove qFlo) liftIO $ do WS.assertMatchN_ (3 # Second) [wsA] $ wsAssertMembersLeave qconv qBob [qFlo] @@ -448,7 +448,7 @@ notifyUpdate extras action etype edata = do FedGalley.cuAction = action } WS.bracketR2 c alice charlie $ \(wsA, wsC) -> do - FedGalley.onConversationUpdated fedGalleyClient bdom cu + FedGalley.onConversationUpdated (fedGalleyClient bdom) cu liftIO $ do WS.assertMatch_ (5 # Second) wsA $ \n -> do let e = List1.head (WS.unpackPayload n) @@ -548,7 +548,7 @@ notifyDeletedConversation = do FedGalley.cuAlreadyPresentUsers = [alice], FedGalley.cuAction = ConversationActionDelete } - FedGalley.onConversationUpdated fedGalleyClient bobDomain cu + FedGalley.onConversationUpdated (fedGalleyClient bobDomain) cu liftIO $ do WS.assertMatch_ (5 # Second) wsAlice $ \n -> do @@ -606,7 +606,7 @@ addRemoteUser = do ConversationActionAddMembers (qdee :| [qeve, qflo]) roleNameWireMember } WS.bracketRN c (map qUnqualified [qalice, qcharlie, qdee, qflo]) $ \[wsA, wsC, wsD, wsF] -> do - FedGalley.onConversationUpdated fedGalleyClient bdom cu + FedGalley.onConversationUpdated (fedGalleyClient bdom) cu void . liftIO $ do WS.assertMatchN_ (5 # Second) [wsA, wsD] $ wsAssertMemberJoinWithRole qconv qbob [qeve, qdee] roleNameWireMember @@ -630,15 +630,15 @@ leaveConversationSuccess = do connectWithRemoteUser alice qEve let mockedResponse fedReq = do - let success :: ToJSON a => a -> IO F.OutwardResponse - success = pure . F.OutwardResponseBody . LBS.toStrict . A.encode - getUsersPath = Just "/federation/get-users-by-ids" - case (F.domain fedReq, F.path <$> F.request fedReq) of + let success :: ToJSON a => a -> IO LByteString + success = pure . A.encode + getUsersRPC = "get-users-by-ids" + case (frTargetDomain fedReq, frRPC fedReq) of (d, mp) - | d == domainText remoteDomain1 && mp == getUsersPath -> + | d == remoteDomain1 && mp == getUsersRPC -> success [mkProfile qChad (Name "Chad"), mkProfile qDee (Name "Dee")] (d, mp) - | d == domainText remoteDomain2 && mp == getUsersPath -> + | d == remoteDomain2 && mp == getUsersRPC -> success [mkProfile qEve (Name "Eve")] _ -> success () @@ -674,8 +674,8 @@ leaveConversationSuccess = do void . WS.assertMatch (3 # Second) wsBob $ wsAssertMembersLeave qconvId qChad [qChad] - let [remote1GalleyFederatedRequest] = fedRequestsForDomain remoteDomain1 F.Galley federatedRequests - [remote2GalleyFederatedRequest] = fedRequestsForDomain remoteDomain2 F.Galley federatedRequests + let [remote1GalleyFederatedRequest] = fedRequestsForDomain remoteDomain1 Galley federatedRequests + [remote2GalleyFederatedRequest] = fedRequestsForDomain remoteDomain2 Galley federatedRequests assertRemoveUpdate remote1GalleyFederatedRequest qconvId qChad [qUnqualified qChad, qUnqualified qDee] qChad assertRemoveUpdate remote2GalleyFederatedRequest qconvId qChad [qUnqualified qEve] qChad @@ -754,7 +754,7 @@ onMessageSent = do FedGalley.cuAction = ConversationActionAddMembers (pure qalice) roleNameWireMember } - FedGalley.onConversationUpdated fedGalleyClient bdom cu + FedGalley.onConversationUpdated (fedGalleyClient bdom) cu let txt = "Hello from another backend" msg client = Map.fromList [(client, txt)] @@ -776,7 +776,7 @@ onMessageSent = do -- send message to alice and check reception WS.bracketAsClientRN c [(alice, aliceC1), (alice, aliceC2), (eve, eveC)] $ \[wsA1, wsA2, wsE] -> do - FedGalley.onMessageSent fedGalleyClient bdom rm + FedGalley.onMessageSent (fedGalleyClient bdom) rm liftIO $ do -- alice should receive the message on her first client WS.assertMatch_ (5 # Second) wsA1 $ \n -> do @@ -830,7 +830,7 @@ sendMessage = do connectWithRemoteUser aliceId chad -- conversation let responses1 req - | fmap F.component (F.request req) == Just F.Brig = + | frComponent req == Brig = toJSON [bobProfile, chadProfile] | otherwise = toJSON () (convId, requests1) <- @@ -847,8 +847,8 @@ sendMessage = do [galleyReq] <- case requests1 of xs@[_] -> pure xs _ -> assertFailure "unexpected number of requests" - fmap F.component (F.request galleyReq) @?= Just F.Galley - fmap F.path (F.request galleyReq) @?= Just "/federation/on-conversation-created" + frComponent galleyReq @?= Galley + frRPC galleyReq @?= "on-conversation-created" let conv = Qualified convId localDomain -- we use bilge instead of the federation client to make a federated request @@ -868,7 +868,7 @@ sendMessage = do (LBS.fromStrict (Protolens.encodeMessage msg)) } let responses2 req - | fmap F.component (F.request req) == Just F.Brig = + | frComponent req == Brig = toJSON ( Map.fromList [ (chadId, Set.singleton (PubClient chadClient Nothing)), @@ -907,9 +907,9 @@ sendMessage = do [_clientReq, receiveReq] <- case requests2 of xs@[_, _] -> pure xs _ -> assertFailure "unexpected number of requests" - fmap F.component (F.request receiveReq) @?= Just F.Galley - fmap F.path (F.request receiveReq) @?= Just "/federation/on-message-sent" - rm <- case A.decode . LBS.fromStrict . F.body =<< F.request receiveReq of + frComponent receiveReq @?= Galley + frRPC receiveReq @?= "on-message-sent" + rm <- case A.decode (frBody receiveReq) of Nothing -> assertFailure "invalid federated request body" Just x -> pure (x :: FedGalley.RemoteMessage ConvId) FedGalley.rmSender rm @?= bob @@ -974,8 +974,8 @@ onUserDeleted = do (resp, rpcCalls) <- withTempMockFederator (const ()) $ do let udcn = FedGalley.UserDeletedConversationsNotification - { FedGalley.udcnUser = tUnqualified bob, - FedGalley.udcnConversations = + { FedGalley.udcvUser = tUnqualified bob, + FedGalley.udcvConversations = unsafeRange [ qUnqualified ooConvId, qUnqualified groupConvId, @@ -987,7 +987,7 @@ onUserDeleted = do responseJsonError =<< post ( g - . paths ["federation", "on-user-deleted", "conversations"] + . paths ["federation", "on-user-deleted-conversations"] . content "application/json" . header "Wire-Origin-Domain" (toByteString' (tDomain bob)) . json udcn @@ -1022,7 +1022,7 @@ onUserDeleted = do assertEqual ("Expected 2 RPC calls, got: " <> show rpcCalls) 2 (length rpcCalls) -- Assertions about RPC to bDomain - bobDomainRPC <- assertOne $ filter (\c -> F.domain c == domainText bDomain) rpcCalls + bobDomainRPC <- assertOne $ filter (\c -> frTargetDomain c == bDomain) rpcCalls bobDomainRPCReq <- assertRight $ parseFedRequest bobDomainRPC FedGalley.cuOrigUserId bobDomainRPCReq @?= qUntagged bob FedGalley.cuConvId bobDomainRPCReq @?= qUnqualified groupConvId @@ -1030,7 +1030,7 @@ onUserDeleted = do FedGalley.cuAction bobDomainRPCReq @?= ConversationActionRemoveMembers (pure $ qUntagged bob) -- Assertions about RPC to 'cDomain' - cDomainRPC <- assertOne $ filter (\c -> F.domain c == domainText cDomain) rpcCalls + cDomainRPC <- assertOne $ filter (\c -> frTargetDomain c == cDomain) rpcCalls cDomainRPCReq <- assertRight $ parseFedRequest cDomainRPC FedGalley.cuOrigUserId cDomainRPCReq @?= qUntagged bob FedGalley.cuConvId cDomainRPCReq @?= qUnqualified groupConvId diff --git a/services/galley/test/integration/API/MessageTimer.hs b/services/galley/test/integration/API/MessageTimer.hs index 71d47cdf85f..f0e1d91fb21 100644 --- a/services/galley/test/integration/API/MessageTimer.hs +++ b/services/galley/test/integration/API/MessageTimer.hs @@ -25,7 +25,6 @@ import Bilge hiding (timeout) import Bilge.Assert import Control.Lens (view) import Data.Aeson (eitherDecode) -import qualified Data.ByteString.Lazy as LBS import Data.Domain import Data.Id import qualified Data.LegalHold as LH @@ -33,6 +32,7 @@ import Data.List1 import qualified Data.List1 as List1 import Data.Misc import Data.Qualified +import Federator.MockServer (FederatedRequest (..)) import Galley.Types import Galley.Types.Conversations.Roles import qualified Galley.Types.Teams as Teams @@ -47,7 +47,7 @@ import TestHelpers import TestSetup import Wire.API.Conversation.Action import qualified Wire.API.Federation.API.Galley as F -import qualified Wire.API.Federation.GRPC.Types as F +import Wire.API.Federation.Component import qualified Wire.API.Team.Member as Member tests :: IO TestSetup -> TestTree @@ -167,10 +167,10 @@ messageTimerChangeWithRemotes = do req <- assertOne requests liftIO $ do - F.domain req @?= domainText remoteDomain - fmap F.component (F.request req) @?= Just F.Galley - fmap F.path (F.request req) @?= Just "/federation/on-conversation-updated" - Just (Right cu) <- pure $ fmap (eitherDecode . LBS.fromStrict . F.body) (F.request req) + frTargetDomain req @?= remoteDomain + frComponent req @?= Galley + frRPC req @?= "on-conversation-updated" + Right cu <- pure . eitherDecode . frBody $ req F.cuConvId cu @?= qUnqualified qconv F.cuAction cu @?= ConversationActionMessageTimerUpdate diff --git a/services/galley/test/integration/API/Roles.hs b/services/galley/test/integration/API/Roles.hs index 615442b2c7e..0ef2b52ef11 100644 --- a/services/galley/test/integration/API/Roles.hs +++ b/services/galley/test/integration/API/Roles.hs @@ -23,13 +23,13 @@ import Bilge.Assert import Control.Lens (view) import Data.Aeson (eitherDecode) import Data.ByteString.Conversion (toByteString') -import qualified Data.ByteString.Lazy as LBS import Data.Domain import Data.Id import Data.List1 import qualified Data.List1 as List1 import Data.Qualified import qualified Data.Set as Set +import Federator.MockServer (FederatedRequest (..)) import Galley.Types import Galley.Types.Conversations.Roles import Gundeck.Types.Notification (Notification (..)) @@ -43,7 +43,7 @@ import TestHelpers import TestSetup import Wire.API.Conversation.Action import qualified Wire.API.Federation.API.Galley as F -import qualified Wire.API.Federation.GRPC.Types as F +import Wire.API.Federation.Component tests :: IO TestSetup -> TestTree tests s = @@ -196,10 +196,10 @@ roleUpdateRemoteMember = do misConvRoleName = Just roleNameWireMember } liftIO $ do - F.domain req @?= domainText remoteDomain - fmap F.component (F.request req) @?= Just F.Galley - fmap F.path (F.request req) @?= Just "/federation/on-conversation-updated" - Just (Right cu) <- pure $ fmap (eitherDecode . LBS.fromStrict . F.body) (F.request req) + frTargetDomain req @?= remoteDomain + frComponent req @?= Galley + frRPC req @?= "on-conversation-updated" + Right cu <- pure . eitherDecode . frBody $ req F.cuConvId cu @?= qUnqualified qconv F.cuAction cu @?= ConversationActionMemberUpdate qcharlie (OtherMemberUpdate (Just roleNameWireMember)) @@ -265,10 +265,10 @@ roleUpdateWithRemotes = do misConvRoleName = Just roleNameWireAdmin } liftIO $ do - F.domain req @?= domainText remoteDomain - fmap F.component (F.request req) @?= Just F.Galley - fmap F.path (F.request req) @?= Just "/federation/on-conversation-updated" - Just (Right cu) <- pure $ fmap (eitherDecode . LBS.fromStrict . F.body) (F.request req) + frTargetDomain req @?= remoteDomain + frComponent req @?= Galley + frRPC req @?= "on-conversation-updated" + Right cu <- pure . eitherDecode . frBody $ req F.cuConvId cu @?= qUnqualified qconv F.cuAction cu @?= ConversationActionMemberUpdate qcharlie (OtherMemberUpdate (Just roleNameWireAdmin)) @@ -309,10 +309,10 @@ accessUpdateWithRemotes = do req <- assertOne requests liftIO $ do - F.domain req @?= domainText remoteDomain - fmap F.component (F.request req) @?= Just F.Galley - fmap F.path (F.request req) @?= Just "/federation/on-conversation-updated" - Just (Right cu) <- pure $ fmap (eitherDecode . LBS.fromStrict . F.body) (F.request req) + frTargetDomain req @?= remoteDomain + frComponent req @?= Galley + frRPC req @?= "on-conversation-updated" + Right cu <- pure . eitherDecode . frBody $ req F.cuConvId cu @?= qUnqualified qconv F.cuAction cu @?= ConversationActionAccessUpdate access F.cuAlreadyPresentUsers cu @?= [qUnqualified qalice] diff --git a/services/galley/test/integration/API/Util.hs b/services/galley/test/integration/API/Util.hs index 42a18927fb9..b1cb862d558 100644 --- a/services/galley/test/integration/API/Util.hs +++ b/services/galley/test/integration/API/Util.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -- This file is part of the Wire Server implementation. @@ -28,6 +27,7 @@ import Brig.Types import Brig.Types.Intra (UserAccount (..), UserSet (..)) import Brig.Types.Team.Invitation import Brig.Types.User.Auth (CookieLabel (..)) +import Control.Exception (throw) import Control.Lens hiding (from, to, (#), (.=)) import Control.Monad.Catch (MonadCatch, MonadMask, finally) import Control.Monad.Except (ExceptT, runExceptT) @@ -63,9 +63,12 @@ import qualified Data.Set as Set import Data.String.Conversions (ST, cs) import Data.Text.Encoding (decodeUtf8) import qualified Data.Text.Encoding as Text +import qualified Data.Text.Lazy.Encoding as T import Data.Time (getCurrentTime) import qualified Data.UUID as UUID import Data.UUID.V4 +import Federator.MockServer (FederatedRequest (..)) +import qualified Federator.MockServer as Mock import Galley.Intra.User (chunkify) import qualified Galley.Options as Opts import qualified Galley.Run as Run @@ -89,10 +92,10 @@ import Gundeck.Types.Notification queuedTime, ) import Imports -import Network.HTTP.Types (methodPost, status200) +import qualified Network.HTTP.Types as HTTP import Network.Wai (Application, defaultRequest) import qualified Network.Wai as Wai -import qualified Network.Wai.Test as Test +import qualified Network.Wai.Test as Wai import Servant (Handler, HasServer, Server, ServerT, serve, (:<|>) (..)) import Servant.API.Generic (ToServantApi) import Servant.Server.Generic (AsServerT, genericServerT) @@ -113,10 +116,8 @@ import Wire.API.Event.Conversation (_EdConversation, _EdMembersJoin, _EdMembersL import qualified Wire.API.Event.Team as TE import qualified Wire.API.Federation.API.Brig as FederatedBrig import qualified Wire.API.Federation.API.Galley as FederatedGalley +import Wire.API.Federation.Component import Wire.API.Federation.Domain (originDomainHeaderName) -import Wire.API.Federation.GRPC.Types (FederatedRequest, OutwardResponse (..)) -import qualified Wire.API.Federation.GRPC.Types as F -import qualified Wire.API.Federation.Mock as Mock import Wire.API.Message import qualified Wire.API.Message.Proto as Proto import Wire.API.Routes.Internal.Brig.Connection @@ -572,7 +573,7 @@ postConvWithRemoteUsers :: UserId -> NewConv -> TestM (Response (Maybe LByteString)) -postConvWithRemoteUsers u n = do +postConvWithRemoteUsers u n = fmap fst $ withTempMockFederator (const ()) $ postConvQualified u n {newConvName = setName (newConvName n)} @@ -630,7 +631,7 @@ postO2OConv u1 u2 n = do postConnectConv :: UserId -> UserId -> Text -> Text -> Maybe Text -> TestM ResponseLBS postConnectConv a b name msg email = do - qb <- Qualified <$> pure b <*> viewFederationDomain + qb <- pure (Qualified b) <*> viewFederationDomain g <- view tsGalley post $ g @@ -685,9 +686,9 @@ postProteusMessageQualifiedWithMockFederator :: [(Qualified UserId, ClientId, ByteString)] -> ByteString -> ClientMismatchStrategy -> - (Domain -> FederatedBrig.Api (AsServerT Handler)) -> - (Domain -> FederatedGalley.Api (AsServerT Handler)) -> - TestM (ResponseLBS, Mock.ReceivedRequests) + (Domain -> FederatedBrig.BrigApi (AsServerT Handler)) -> + (Domain -> FederatedGalley.GalleyApi (AsServerT Handler)) -> + TestM (ResponseLBS, [FederatedRequest]) postProteusMessageQualifiedWithMockFederator senderUser senderClient convId recipients dat strat brigApi galleyApi = do localDomain <- viewFederationDomain withTempServantMockFederator brigApi galleyApi localDomain $ @@ -1248,19 +1249,18 @@ registerRemoteConv convId originUser name othMembers = do fedGalleyClient <- view tsFedGalleyClient now <- liftIO getCurrentTime FederatedGalley.onConversationCreated - fedGalleyClient - (qDomain convId) + (fedGalleyClient (qDomain convId)) ( FederatedGalley.NewRemoteConversation - { rcTime = now, - rcOrigUserId = originUser, - rcCnvId = qUnqualified convId, - rcCnvType = RegularConv, - rcCnvAccess = [], - rcCnvAccessRole = ActivatedAccessRole, - rcCnvName = name, - rcNonCreatorMembers = othMembers, - rcMessageTimer = Nothing, - rcReceiptMode = Nothing + { FederatedGalley.rcTime = now, + FederatedGalley.rcOrigUserId = originUser, + FederatedGalley.rcCnvId = qUnqualified convId, + FederatedGalley.rcCnvType = RegularConv, + FederatedGalley.rcCnvAccess = [], + FederatedGalley.rcCnvAccessRole = ActivatedAccessRole, + FederatedGalley.rcCnvName = name, + FederatedGalley.rcNonCreatorMembers = othMembers, + FederatedGalley.rcMessageTimer = Nothing, + FederatedGalley.rcReceiptMode = Nothing } ) @@ -1500,11 +1500,11 @@ assertNoMsg ws f = do Left _ -> return () -- expected Right _ -> assertFailure "Unexpected message" -assertRemoveUpdate :: (MonadIO m, HasCallStack) => F.Request -> Qualified ConvId -> Qualified UserId -> [UserId] -> Qualified UserId -> m () +assertRemoveUpdate :: (MonadIO m, HasCallStack) => FederatedRequest -> Qualified ConvId -> Qualified UserId -> [UserId] -> Qualified UserId -> m () assertRemoveUpdate req qconvId remover alreadyPresentUsers victim = liftIO $ do - F.path req @?= "/federation/on-conversation-updated" - F.originDomain req @?= (domainText . qDomain) qconvId - let Just cu = decodeStrict (F.body req) + frRPC req @?= "on-conversation-updated" + frOriginDomain req @?= qDomain qconvId + let Just cu = decode (frBody req) FederatedGalley.cuOrigUserId cu @?= remover FederatedGalley.cuConvId cu @?= qUnqualified qconvId sort (FederatedGalley.cuAlreadyPresentUsers cu) @?= sort alreadyPresentUsers @@ -2227,85 +2227,78 @@ withTempMockFederator :: (MonadIO m, ToJSON a, HasGalley m, MonadMask m) => (FederatedRequest -> a) -> SessionT m b -> - m (b, Mock.ReceivedRequests) -withTempMockFederator resp = withTempMockFederator' (pure . oresp) - where - oresp = OutwardResponseBody . Lazy.toStrict . encode . resp + m (b, [FederatedRequest]) +withTempMockFederator resp = withTempMockFederator' $ pure . encode . resp withTempMockFederator' :: (MonadIO m, HasGalley m, MonadMask m) => - (FederatedRequest -> IO F.OutwardResponse) -> + (FederatedRequest -> IO LByteString) -> SessionT m b -> - m (b, Mock.ReceivedRequests) + m (b, [FederatedRequest]) withTempMockFederator' resp action = do opts <- viewGalleyOpts - assertRightT - . Mock.withTempMockFederator st0 (lift . resp) - $ \st -> lift $ do - let opts' = - opts & Opts.optFederator - ?~ Endpoint "127.0.0.1" (fromIntegral (Mock.serverPort st)) - withSettingsOverrides opts' action - where - st0 = Mock.initState (Domain "example.com") + Mock.withTempMockFederator [("Content-Type", "application/json")] resp $ \mockPort -> do + let opts' = + opts & Opts.optFederator + ?~ Endpoint "127.0.0.1" (fromIntegral mockPort) + withSettingsOverrides opts' action +-- Start a mock federator. Use proveded Servant handler for the mocking mocking function. withTempServantMockFederator :: (MonadMask m, MonadIO m, HasGalley m) => - (Domain -> FederatedBrig.Api (AsServerT Handler)) -> - (Domain -> FederatedGalley.Api (AsServerT Handler)) -> + (Domain -> FederatedBrig.BrigApi (AsServerT Handler)) -> + (Domain -> FederatedGalley.GalleyApi (AsServerT Handler)) -> Domain -> SessionT m b -> - m (b, Mock.ReceivedRequests) + m (b, [FederatedRequest]) withTempServantMockFederator brigApi galleyApi originDomain = withTempMockFederator' mock where server :: Domain -> ServerT CombinedBrigAndGalleyAPI Handler server d = genericServerT (brigApi d) :<|> genericServerT (galleyApi d) - mock :: F.FederatedRequest -> IO F.OutwardResponse + mock :: FederatedRequest -> IO LByteString mock req = - makeFedRequestToServant @CombinedBrigAndGalleyAPI originDomain (server (Domain (F.domain req))) req + makeFedRequestToServant @CombinedBrigAndGalleyAPI originDomain (server (frTargetDomain req)) req -type CombinedBrigAndGalleyAPI = ToServantApi FederatedBrig.Api :<|> ToServantApi FederatedGalley.Api +type CombinedBrigAndGalleyAPI = ToServantApi FederatedBrig.BrigApi :<|> ToServantApi FederatedGalley.GalleyApi +-- Starts a servant Application in Network.Wai.Test session and runs the +-- FederatedRequest against it. makeFedRequestToServant :: forall (api :: *). HasServer api '[] => Domain -> Server api -> - F.FederatedRequest -> - IO F.OutwardResponse -makeFedRequestToServant originDomain server fedRequest = - Test.runSession session app + FederatedRequest -> + IO LByteString +makeFedRequestToServant originDomain server fedRequest = do + sresp <- Wai.runSession session app + let status = Wai.simpleStatus sresp + bdy = Wai.simpleBody sresp + if HTTP.statusIsSuccessful status + then pure bdy + else throw (Mock.MockErrorResponse status (T.decodeUtf8 bdy)) where app :: Application app = serve (Proxy @api) server - session :: Test.Session F.OutwardResponse + session :: Wai.Session Wai.SResponse session = do - let req = fromMaybe (error "no request") (F.request fedRequest) - response <- - Test.srequest - ( Test.SRequest - (toRequestWithoutBody req) - (cs . F.body $ req) - ) - if Test.simpleStatus response == status200 - then pure (F.OutwardResponseBody (cs (Test.simpleBody response))) - else do - pure (F.OutwardResponseError (F.OutwardError F.GrpcError (cs (Test.simpleBody response)))) - - toRequestWithoutBody :: F.Request -> Wai.Request - toRequestWithoutBody req = - defaultRequest - { Wai.requestMethod = methodPost, - Wai.pathInfo = fmap cs . drop 1 . C.split '/' . F.path $ req, - Wai.requestHeaders = - [ (CI.mk "Content-Type", "application/json"), - (CI.mk "Accept", "application/json"), - (originDomainHeaderName, cs . domainText $ originDomain) - ] - } + Wai.srequest + ( Wai.SRequest + ( defaultRequest + { Wai.requestMethod = HTTP.methodPost, + Wai.pathInfo = [frRPC fedRequest], + Wai.requestHeaders = + [ (CI.mk "Content-Type", "application/json"), + (CI.mk "Accept", "application/json"), + (originDomainHeaderName, cs . domainText $ originDomain) + ] + } + ) + (frBody fedRequest) + ) assertRight :: (MonadIO m, Show a, HasCallStack) => Either a b -> m b assertRight = \case @@ -2432,44 +2425,35 @@ checkTimeout = 3 # Second -- | The function is used in conjuction with 'withTempMockFederator' to mock -- responses by Brig on the mocked side of federation. -mockedFederatedBrigResponse :: [(Qualified UserId, Text)] -> F.FederatedRequest -> Maybe Value +mockedFederatedBrigResponse :: [(Qualified UserId, Text)] -> FederatedRequest -> Maybe Value mockedFederatedBrigResponse users req - | fmap F.component (F.request req) == Just F.Brig = + | frComponent req == Brig = Just . toJSON $ [mkProfile mem (Name name) | (mem, name) <- users] | otherwise = Nothing -- | Combine two mocked services such that for a given request a JSON response -- is produced. joinMockedFederatedResponses :: - (F.FederatedRequest -> Maybe Value) -> - (F.FederatedRequest -> Maybe Value) -> - F.FederatedRequest -> + (FederatedRequest -> Maybe Value) -> + (FederatedRequest -> Maybe Value) -> + FederatedRequest -> Value joinMockedFederatedResponses service1 service2 req = fromMaybe (toJSON ()) (service1 req <|> service2 req) -- | Only Brig is mocked. -onlyMockedFederatedBrigResponse :: [(Qualified UserId, Text)] -> F.FederatedRequest -> Value +onlyMockedFederatedBrigResponse :: [(Qualified UserId, Text)] -> FederatedRequest -> Value onlyMockedFederatedBrigResponse users = joinMockedFederatedResponses (mockedFederatedBrigResponse users) (const Nothing) -fedRequestsForDomain :: HasCallStack => Domain -> F.Component -> [F.FederatedRequest] -> [F.Request] +fedRequestsForDomain :: HasCallStack => Domain -> Component -> [FederatedRequest] -> [FederatedRequest] fedRequestsForDomain domain component = - map (fromJust . F.request) - . filter - ( \req -> - F.domain req == domainText domain - && fmap F.component (F.request req) == Just component - ) + filter $ \req -> frTargetDomain req == domain && frComponent req == component -parseFedRequest :: FromJSON a => F.FederatedRequest -> Either String a -parseFedRequest fr = - case F.request fr of - Just r -> - (eitherDecode . cs) (F.body r) - Nothing -> Left "No request" +parseFedRequest :: FromJSON a => FederatedRequest -> Either String a +parseFedRequest fr = eitherDecode (frBody fr) assertOne :: (HasCallStack, MonadIO m, Show a) => [a] -> m a assertOne [a] = pure a @@ -2513,7 +2497,7 @@ generateRemoteAndConvIdWithDomain remoteDomain shouldBeLocal lUserId = do then pure (qTagUnsafe other, convId) else generateRemoteAndConvIdWithDomain remoteDomain shouldBeLocal lUserId -matchFedRequest :: Domain -> ByteString -> FederatedRequest -> Bool +matchFedRequest :: Domain -> Text -> FederatedRequest -> Bool matchFedRequest domain reqpath req = - F.domain req == domainText domain - && fmap F.path (F.request req) == Just reqpath + frTargetDomain req == domain + && frRPC req == reqpath diff --git a/services/galley/test/integration/TestSetup.hs b/services/galley/test/integration/TestSetup.hs index 0c48a9526ce..30550c46cbc 100644 --- a/services/galley/test/integration/TestSetup.hs +++ b/services/galley/test/integration/TestSetup.hs @@ -46,16 +46,22 @@ import qualified Cassandra as Cql import Control.Lens (makeLenses, view, (^.)) import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow) import Data.Aeson +import Data.ByteString.Conversion +import Data.Domain import qualified Data.Text as Text import qualified Galley.Aws as Aws import Galley.Options (Opts) import Imports +import qualified Network.HTTP.Client as HTTP import qualified Servant.Client as Servant +import Servant.Client.Core.BaseUrl +import qualified Servant.Client.Core.Request as Client import Servant.Client.Generic (AsClientT) import qualified Servant.Client.Generic as Servant import Test.Tasty.HUnit import Util.Options -import qualified Wire.API.Federation.API.Galley as FedGalley +import Wire.API.Federation.API +import Wire.API.Federation.Domain type GalleyR = Request -> Request @@ -100,7 +106,7 @@ newtype TestM a = TestM {runTestM :: ReaderT TestSetup IO a} MonadFail ) -type FedGalleyClient = FedGalley.Api (AsClientT TestM) +type FedGalleyClient = FedApi 'Galley (AsClientT TestM) data TestSetup = TestSetup { _tsGConf :: Opts, @@ -112,7 +118,7 @@ data TestSetup = TestSetup _tsAwsEnv :: Maybe Aws.Env, _tsMaxConvSize :: Word16, _tsCass :: Cql.ClientState, - _tsFedGalleyClient :: FedGalleyClient + _tsFedGalleyClient :: Domain -> FedGalleyClient } makeLenses ''TestSetup @@ -122,17 +128,24 @@ instance MonadHttp TestM where manager <- view tsManager liftIO $ withResponse req manager handler -mkFedGalleyClient :: Endpoint -> FedGalleyClient -mkFedGalleyClient galleyEndpoint = Servant.genericClientHoist servantClienMToHttp +mkFedGalleyClient :: Endpoint -> Domain -> FedGalleyClient +mkFedGalleyClient galleyEndpoint originDomain = Servant.genericClientHoist servantClienMToHttp where servantClienMToHttp :: Servant.ClientM a -> TestM a servantClienMToHttp act = do - let brigHost = Text.unpack $ galleyEndpoint ^. epHost + let galleyHost = Text.unpack $ galleyEndpoint ^. epHost brigPort = fromInteger . toInteger $ galleyEndpoint ^. epPort - baseUrl = Servant.BaseUrl Servant.Http brigHost brigPort "" + baseUrl = Servant.BaseUrl Servant.Http galleyHost brigPort "/federation" mgr' <- view tsManager - let clientEnv = Servant.ClientEnv mgr' baseUrl Nothing Servant.defaultMakeClientRequest + let clientEnv = Servant.ClientEnv mgr' baseUrl Nothing makeClientRequest eitherRes <- liftIO $ Servant.runClientM act clientEnv case eitherRes of Right res -> pure res Left err -> liftIO $ assertFailure $ "Servant client failed with: " <> show err + makeClientRequest :: BaseUrl -> Client.Request -> HTTP.Request + makeClientRequest burl req = + let req' = Servant.defaultMakeClientRequest burl req + in req' + { HTTP.requestHeaders = + HTTP.requestHeaders req' <> [(originDomainHeaderName, toByteString' originDomain)] + } diff --git a/stack.yaml b/stack.yaml index 6c4c22a8e36..12671354d5b 100644 --- a/stack.yaml +++ b/stack.yaml @@ -162,6 +162,7 @@ extra-deps: - wai-predicates-1.0.0 - redis-io-1.1.0 - polysemy-mocks-0.2.0.0 +- warp-3.3.17 # Not latest as last one breaks wai-routing - wai-route-0.4.0 @@ -207,40 +208,10 @@ extra-deps: - git: https://github.com/dpwright/HaskellNet-SSL commit: ca84ef29a93eaef7673fa58056cdd8dae1568d2d # master (Sep 14, 2020) -# mu -- mu-rpc-0.4.0.1 -- mu-optics-0.3.0.1 -- mu-avro-0.4.0.4 -- mu-protobuf-0.4.2.0 -- mu-schema-0.3.1.2 -- mu-grpc-server-0.4.0.0 -- mu-grpc-client-0.4.0.1 -- mu-grpc-common-0.4.0.0 -- compendium-client-0.2.1.1 -# dependencies of mu -- http2-grpc-types-0.5.0.0 -- http2-grpc-proto3-wire-0.1.0.0 -- warp-grpc-0.4.0.1 -- proto3-wire-1.2.0 -- parameterized-0.5.0.0 - -# Unreleased master. -# Needed for https://github.com/lucasdicioccio/http2-client/pull/75 -- git: https://github.com/lucasdicioccio/http2-client - commit: 73f5975e18eda9d071aa5548fcea6b5a51e61769 - -# Fix in PRs: https://github.com/haskell-grpc-native/http2-grpc-haskell/pull/48 -# and https://github.com/haskell-grpc-native/http2-grpc-haskell/pull/46 -- git: https://github.com/wireapp/http2-grpc-haskell - commit: eea98418672626eafbace3181ca34bf44bee91c0 - subdirs: - - http2-client-grpc - -# Fix for issue #27: https://github.com/kazu-yamamoto/http2/issues/27 -# PR here: https://github.com/kazu-yamamoto/http2/pull/28 -# Note: the commit used here is based on version 2.0.6 of http2 -- git: https://github.com/wireapp/http2 # (2021-06-09) branch: header-encoding-0-size-table-backport - commit: 7c465be1201e0945b106f7cc6176ac1b1193be13 +# Fix for connection preface race condition +# https://github.com/kazu-yamamoto/http2/pull/33 +- git: https://github.com/wireapp/http2 + commit: 1ee1ce432d923839dab6782410e91dc17df2a880 # preface-race branch # Fix in PR: https://github.com/bos/snappy/pull/7 - git: https://github.com/wireapp/snappy diff --git a/stack.yaml.lock b/stack.yaml.lock index d830e30c3b3..6da7fa2060c 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -454,6 +454,13 @@ packages: sha256: 8218e3dde278ca1f01d19009fad40f603e1b17993a519d15fe6319e3a827cc01 original: hackage: polysemy-mocks-0.2.0.0 +- completed: + hackage: warp-3.3.17@sha256:3a3ea203141d00d2244b511ee99174b8ed58fc862552755d470a25a44ce5275b,10910 + pantry-tree: + size: 3973 + sha256: 49b90267427705454477f4d2fa5755d0006826ede89e931cd84b4a0a658bd525 + original: + hackage: warp-3.3.17 - completed: hackage: wai-route-0.4.0@sha256:ee52f13d2945e4a56147e91e515e184f840654f2e3d9071c73bec3d8aa1f4444,2119 pantry-tree: @@ -633,139 +640,17 @@ packages: original: git: https://github.com/dpwright/HaskellNet-SSL commit: ca84ef29a93eaef7673fa58056cdd8dae1568d2d -- completed: - hackage: mu-rpc-0.4.0.1@sha256:24f2516926a669f860b59d17ed8af6d0704361b5abed30f4e7eb80fb685ae8bc,1383 - pantry-tree: - size: 445 - sha256: 235597681d97b0789bc7437c752658f2585248d889a289c09532e3e535640cfa - original: - hackage: mu-rpc-0.4.0.1 -- completed: - hackage: mu-optics-0.3.0.1@sha256:c3494c71c6300e6a0dcb77c9782481150956e912c1b47fccd69cbb795e461d52,1068 - pantry-tree: - size: 172 - sha256: 6f8275b8db1dce6136ebd2eb831495af39774d9560d8d07e60d5da09a5f3ed99 - original: - hackage: mu-optics-0.3.0.1 -- completed: - hackage: mu-avro-0.4.0.4@sha256:10e317c633c5152a26e89becba749456b76f70eb640d1c0b2ccdc0e45a7ef5da,2096 - pantry-tree: - size: 541 - sha256: 26fd2a714615b6c2c0459178fb5f350848ce64be5c33076c4ddaff9c74adb278 - original: - hackage: mu-avro-0.4.0.4 -- completed: - hackage: mu-protobuf-0.4.2.0@sha256:4787a2688abdda107e150736433b61448acdf0b71eb0c174232239b4c143f78b,2119 - pantry-tree: - size: 640 - sha256: ad3ec2fa09fea08c1c7c5181db7ed4440c030cc6c9dbc708a9a58155c13ca8fa - original: - hackage: mu-protobuf-0.4.2.0 -- completed: - hackage: mu-schema-0.3.1.2@sha256:c05e58de29d50376638d19dd3357cd3644d39f984664484f3568d5305b3034d9,1933 - pantry-tree: - size: 1061 - sha256: 07d5d0ab3fc6db8e7492311caacbd92f33a343fd173cb51d2915522b3aea8073 - original: - hackage: mu-schema-0.3.1.2 -- completed: - hackage: mu-grpc-server-0.4.0.0@sha256:03963b39f5b0887d261106ec03bfabbd4ccd1489e4c59c6cc216b61a4ffdb52c,2682 - pantry-tree: - size: 334 - sha256: e0d51b2551de2ecce35707b3dc3fabfe67cbd206522d363bf2316b08c2ccbfda - original: - hackage: mu-grpc-server-0.4.0.0 -- completed: - hackage: mu-grpc-client-0.4.0.1@sha256:b09dcf69f0650e0cfd86d6f67544a6350590574f4757f5ee459c57828c3a41ff,2079 - pantry-tree: - size: 562 - sha256: 94e32cdfdee230f090684804fee5ef254c6063f985b913c8efaadbe1dfceafef - original: - hackage: mu-grpc-client-0.4.0.1 -- completed: - hackage: mu-grpc-common-0.4.0.0@sha256:568b5879cd67c0bc0e956d53fb87552bb6d9a6287c5d1b09e2284ed5b04de418,1394 - pantry-tree: - size: 281 - sha256: 7e745ded1cb622178392ae2d5a6d5591af9743b58506de5ed2e17d7d698b0d18 - original: - hackage: mu-grpc-common-0.4.0.0 -- completed: - hackage: compendium-client-0.2.1.1@sha256:cd477438d507273b34b82581ade333921ae997c1618b48af0c1da2a4968623e0,1203 - pantry-tree: - size: 181 - sha256: 18996ce535e40483ca2e29397e606aae551552608f96a6a8cc647ce24e24e937 - original: - hackage: compendium-client-0.2.1.1 -- completed: - hackage: http2-grpc-types-0.5.0.0@sha256:4d34edc06a48496130f19245817a7cd7ea15c78ac8815570c3795ffc4503cf27,1445 - pantry-tree: - size: 405 - sha256: 3a1a94b87acd230b2f750f0077dc47177f37e46a2984b5764390207a83c4d5e4 - original: - hackage: http2-grpc-types-0.5.0.0 -- completed: - hackage: http2-grpc-proto3-wire-0.1.0.0@sha256:4f6c0d27048756155b82ebf7385a20cc8241c7bd854e96d1dd6a1827e75fa410,1504 - pantry-tree: - size: 341 - sha256: d07d5bb883860e3bf928c00312df133a4c195c99bb397865bd67f433f75387b8 - original: - hackage: http2-grpc-proto3-wire-0.1.0.0 -- completed: - hackage: warp-grpc-0.4.0.1@sha256:3859190e4fa23b944cf93ac691b3cec78c2adf4eaff6a4e8070c89fd17915add,1759 - pantry-tree: - size: 709 - sha256: f542ef3e7e03b9cd0b2c0e0c436ce4e68ab37f56195740639034cc3cd28a6b9f - original: - hackage: warp-grpc-0.4.0.1 -- completed: - hackage: proto3-wire-1.2.0@sha256:898c88614ef328fe74d6abc153387a30855af7ccfcebf3b419681133e0fb9291,2837 - pantry-tree: - size: 1009 - sha256: 43009bc2c01725358b40f590bc899f0edbece516090944b6015d40178781759c - original: - hackage: proto3-wire-1.2.0 -- completed: - hackage: parameterized-0.5.0.0@sha256:880717fbb958de1bac015f0a375ab6636f162a72483d987a11e305da6fac6c97,1969 - pantry-tree: - size: 1019 - sha256: 843aed822e03279edf00a2595dfb22038b306f4f0acd6984bd108024c5102f90 - original: - hackage: parameterized-0.5.0.0 -- completed: - name: http2-client - version: 0.10.0.1 - git: https://github.com/lucasdicioccio/http2-client - pantry-tree: - size: 1545 - sha256: d0b3ab62eee8ee4c0ddec7a90fea78090815a54884646ddcdc451ff51d7e262a - commit: 73f5975e18eda9d071aa5548fcea6b5a51e61769 - original: - git: https://github.com/lucasdicioccio/http2-client - commit: 73f5975e18eda9d071aa5548fcea6b5a51e61769 -- completed: - subdir: http2-client-grpc - name: http2-client-grpc - version: 0.8.0.0 - git: https://github.com/wireapp/http2-grpc-haskell - pantry-tree: - size: 455 - sha256: 5599a7b9b801d669e2063ffd4ab767bb8bbf12d20069de0cbd8862bca78d7e42 - commit: eea98418672626eafbace3181ca34bf44bee91c0 - original: - subdir: http2-client-grpc - git: https://github.com/wireapp/http2-grpc-haskell - commit: eea98418672626eafbace3181ca34bf44bee91c0 - completed: name: http2 - version: 2.0.6 + version: 3.0.2 git: https://github.com/wireapp/http2 pantry-tree: - size: 51601 - sha256: 0a048cf85ab9614f2da80e3a8cf72ee7674cecea86b37a5e56011add73e5fa03 - commit: 7c465be1201e0945b106f7cc6176ac1b1193be13 + size: 52771 + sha256: dc6d3868a049d2ed38ef16ca6dd6aeb6b8e8a1e730c664ecdd243ffdb45ee750 + commit: 1ee1ce432d923839dab6782410e91dc17df2a880 original: git: https://github.com/wireapp/http2 - commit: 7c465be1201e0945b106f7cc6176ac1b1193be13 + commit: 1ee1ce432d923839dab6782410e91dc17df2a880 - completed: name: snappy version: 0.2.0.2 diff --git a/tools/convert-to-cabal/README.md b/tools/convert-to-cabal/README.md index c3f4e780814..4dd3a140316 100644 --- a/tools/convert-to-cabal/README.md +++ b/tools/convert-to-cabal/README.md @@ -21,6 +21,7 @@ To make sure Haskell Language Server also builds all projects without optimization run this: ```bash + echo "optimization: False" > ./cabal.project.local ./hack/bin/cabal-project-local-template.sh "ghc-options: -O0" >> ./cabal.project.local ``` From 33ef8721a86e618326f7050b21c6f51f469b6eef Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Wed, 1 Dec 2021 17:29:42 +0100 Subject: [PATCH 23/28] charts/elasticsearch-ephemeral: Allow indices for logs to be created automatically (#1955) --- charts/elasticsearch-ephemeral/templates/es.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/charts/elasticsearch-ephemeral/templates/es.yaml b/charts/elasticsearch-ephemeral/templates/es.yaml index 1da1b217845..855c4488bb5 100644 --- a/charts/elasticsearch-ephemeral/templates/es.yaml +++ b/charts/elasticsearch-ephemeral/templates/es.yaml @@ -32,7 +32,7 @@ spec: - name: "discovery.type" value: "single-node" - name: "action.auto_create_index" - value: ".watches,.triggered_watches,.watcher-history-*" + value: ".watches,.triggered_watches,.watcher-history-*,pod-*,node-*" ports: - containerPort: 9200 name: http From fa905c7df02d8edd87a8fb5dc71dcf0989f9ba46 Mon Sep 17 00:00:00 2001 From: zebot Date: Thu, 2 Dec 2021 12:00:39 +0100 Subject: [PATCH 24/28] chore: [charts] Update webapp version (#1954) Co-authored-by: Zebot --- changelog.d/0-release-notes/webapp-upgrade | 1 + charts/webapp/values.yaml | 2 +- 2 files changed, 2 insertions(+), 1 deletion(-) create mode 100644 changelog.d/0-release-notes/webapp-upgrade diff --git a/changelog.d/0-release-notes/webapp-upgrade b/changelog.d/0-release-notes/webapp-upgrade new file mode 100644 index 00000000000..98cdeaefdff --- /dev/null +++ b/changelog.d/0-release-notes/webapp-upgrade @@ -0,0 +1 @@ +Upgrade webapp version to 2021-12-01-production.0-v0.28.29-0-b13ac32 diff --git a/charts/webapp/values.yaml b/charts/webapp/values.yaml index 169a860900a..7dc263f4e0b 100644 --- a/charts/webapp/values.yaml +++ b/charts/webapp/values.yaml @@ -9,7 +9,7 @@ resources: cpu: "1" image: repository: quay.io/wire/webapp - tag: "2021-11-01-production.0-v0.28.29-0-d919633" + tag: "2021-12-01-production.0-v0.28.29-0-b13ac32" service: https: externalPort: 443 From a5a9e86a61d414f36d5bd1e803f7e87eed6aa38d Mon Sep 17 00:00:00 2001 From: zebot Date: Thu, 2 Dec 2021 15:03:03 +0100 Subject: [PATCH 25/28] chore: [charts] Update webapp version (#1957) Co-authored-by: Zebot --- changelog.d/0-release-notes/webapp-upgrade | 2 +- charts/webapp/values.yaml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/changelog.d/0-release-notes/webapp-upgrade b/changelog.d/0-release-notes/webapp-upgrade index 98cdeaefdff..1e2939ca294 100644 --- a/changelog.d/0-release-notes/webapp-upgrade +++ b/changelog.d/0-release-notes/webapp-upgrade @@ -1 +1 @@ -Upgrade webapp version to 2021-12-01-production.0-v0.28.29-0-b13ac32 +Upgrade webapp version to 2021-12-02-production.0-v0.28.29-0-ec2fa00 diff --git a/charts/webapp/values.yaml b/charts/webapp/values.yaml index 7dc263f4e0b..fb7723a09e6 100644 --- a/charts/webapp/values.yaml +++ b/charts/webapp/values.yaml @@ -9,7 +9,7 @@ resources: cpu: "1" image: repository: quay.io/wire/webapp - tag: "2021-12-01-production.0-v0.28.29-0-b13ac32" + tag: "2021-12-02-production.0-v0.28.29-0-ec2fa00" service: https: externalPort: 443 From 68937c0802b75f3c7c170aaba81f48833808202d Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Thu, 2 Dec 2021 18:27:51 +0100 Subject: [PATCH 26/28] Update webapp version in Helm chart (#1961) --- charts/webapp/values.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/charts/webapp/values.yaml b/charts/webapp/values.yaml index fb7723a09e6..dfc3b9b224c 100644 --- a/charts/webapp/values.yaml +++ b/charts/webapp/values.yaml @@ -9,7 +9,7 @@ resources: cpu: "1" image: repository: quay.io/wire/webapp - tag: "2021-12-02-production.0-v0.28.29-0-ec2fa00" + tag: "2021-12-02-federation-M1-spillover" service: https: externalPort: 443 From 5dc8847a94e81323d1b4d02668a7115353940e4f Mon Sep 17 00:00:00 2001 From: zebot Date: Thu, 2 Dec 2021 18:39:07 +0100 Subject: [PATCH 27/28] Update team-settings version in Helm chart [skip ci] (#1950) * chore: [charts] Update team-settings version * Update tag to 4.3.0-v0.28.28-a2f11cf Co-authored-by: Zebot Co-authored-by: Stefan Matting --- changelog.d/0-release-notes/team-settings-upgrade | 1 + charts/team-settings/values.yaml | 2 +- 2 files changed, 2 insertions(+), 1 deletion(-) create mode 100644 changelog.d/0-release-notes/team-settings-upgrade diff --git a/changelog.d/0-release-notes/team-settings-upgrade b/changelog.d/0-release-notes/team-settings-upgrade new file mode 100644 index 00000000000..3dc0dd5fc68 --- /dev/null +++ b/changelog.d/0-release-notes/team-settings-upgrade @@ -0,0 +1 @@ +Upgrade team-settings version to 4.3.0-v0.28.28-a2f11cf diff --git a/charts/team-settings/values.yaml b/charts/team-settings/values.yaml index 9e702663516..cfd6ddd2656 100644 --- a/charts/team-settings/values.yaml +++ b/charts/team-settings/values.yaml @@ -9,7 +9,7 @@ resources: cpu: "1" image: repository: quay.io/wire/team-settings - tag: "4.2.0-v0.28.28-1e2ef7" + tag: "4.3.0-v0.28.28-a2f11cf" service: https: externalPort: 443 From 2c9348209ceec425d086baed49dccda502176c4a Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Thu, 2 Dec 2021 18:49:14 +0100 Subject: [PATCH 28/28] Update CHANGELOG.md --- CHANGELOG.md | 45 ++++++++++++++++++- changelog.d/0-release-notes/minio-helm | 3 -- .../0-release-notes/team-settings-upgrade | 1 - changelog.d/0-release-notes/webapp-upgrade | 1 - changelog.d/2-features/elasticsearch | 1 - changelog.d/2-features/fluent-bit | 1 - changelog.d/2-features/kibana | 1 - changelog.d/2-features/metrics | 1 - changelog.d/2-features/structured-json-logs | 1 - ...sticsearch-ephemeral-disable-auto-creation | 1 - changelog.d/4-docs/changelog.d-docs | 1 - changelog.d/4-docs/fix-docs | 1 - changelog.d/4-docs/servant.md | 1 - changelog.d/5-internal/in-mem-interpreters | 1 - changelog.d/5-internal/minio-helm | 1 - changelog.d/5-internal/polysemy-1.7.0.0 | 2 - changelog.d/5-internal/polysemy-monad | 1 - changelog.d/5-internal/split-eff2 | 1 - changelog.d/6-federation/drop-grpc | 1 - .../handle-leave-conversation-errors | 1 - 20 files changed, 44 insertions(+), 23 deletions(-) delete mode 100644 changelog.d/0-release-notes/minio-helm delete mode 100644 changelog.d/0-release-notes/team-settings-upgrade delete mode 100644 changelog.d/0-release-notes/webapp-upgrade delete mode 100644 changelog.d/2-features/elasticsearch delete mode 100644 changelog.d/2-features/fluent-bit delete mode 100644 changelog.d/2-features/kibana delete mode 100644 changelog.d/2-features/metrics delete mode 100644 changelog.d/2-features/structured-json-logs delete mode 100644 changelog.d/3-bug-fixes/elasticsearch-ephemeral-disable-auto-creation delete mode 100644 changelog.d/4-docs/changelog.d-docs delete mode 100644 changelog.d/4-docs/fix-docs delete mode 100644 changelog.d/4-docs/servant.md delete mode 100644 changelog.d/5-internal/in-mem-interpreters delete mode 100644 changelog.d/5-internal/minio-helm delete mode 100644 changelog.d/5-internal/polysemy-1.7.0.0 delete mode 100644 changelog.d/5-internal/polysemy-monad delete mode 100644 changelog.d/5-internal/split-eff2 delete mode 100644 changelog.d/6-federation/drop-grpc delete mode 100644 changelog.d/6-federation/handle-leave-conversation-errors diff --git a/CHANGELOG.md b/CHANGELOG.md index e9d44bfbc00..98782d28fa6 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,48 @@ +# [2021-12-02] + +## Release notes + +* Breaking change to the `fake-aws-s3` (part of `fake-aws`) helm chart. We now use minio helm chart from https://charts.min.io. The options are documented [here](https://github.com/minio/minio/tree/master/helm/minio) (#1944) + + Before running the upgrade, the operators must use `kubectl edit deployment fake-aws-s3` and explicitly set `spec.template.spec.containers[0].serviceAccount` and `spec.template.spec.containers[0].serviceAccountName` to null. (#1944) +* Upgrade team-settings version to 4.3.0-v0.28.28-a2f11cf (#1856) +* Upgrade webapp version to 2021-12-02-production.0-v0.28.29-0-ec2fa00 (#1954) + +## Features + +* By default install elasticsearch version 6.8.18 when using the elasticsearch-ephemeral chart (#1952) +* Use fluent-bit chart from fluent.github.io instead of deprecated charts.helm.sh. Previous fluent-bit values are not compatible with the new chart, the documentation for the new chart can be found [here](https://github.com/fluent/helm-charts/tree/main/charts/fluent-bit) (#1952) +* Use kibana chart from helm.elastic.co instead of deprecated charts.helm.sh. Previous kibana values are not compatible with the new chart, the documentation for the new chart can be found [here](https://github.com/elastic/helm-charts/tree/main/kibana). This also upgrades kibana to version 6.8.18. (#1952) +* Use kube-prometheus-stack instead of prometheus-operator and update grafana dashboards for compatibility and add federation endpoints to relevant queries. (#1915) +* Add log format called 'StructuredJSON' for easier log aggregation (#1951) + +## Bug fixes and other updates + +* elasticsearch-ephemeral: Disable automatic creation of indices (#1949) + +## Documentation + +* Document the wire-server PR process better. (#1934) +* Remove documentation of unsupported scim end-point use case. (#1941) +* Document servant setup and combinators (#1933) + +## Internal changes + +* Add in-memory interpreters for most Spar effects (#1920) +* Use minio helm chart in fake-aws-s3 from charts.min.io instead of helm.min.io, the latter seems to be down (#1944) +* Upgrade to polysemy-1.7.0.0 + (#1932) +* Replace Galley monad with polysemy's Sem throughout Galley (#1917) +* Separate VerdictFormatStore effect from AReqIdStore effect (#1925) + +## Federation changes + +* The server-to-server API now uses HTTP2 directly instead of gRPC (#1930) +* Errors when leaving a conversation are now correctly handled instead of resulting in a generic federation error. (#1928) + + # [2021-11-15] ## Release notes @@ -50,7 +93,7 @@ ## Release notes * Upgrade SFT to 2.1.15 (#1849) -* Upgrade team settings to Release: [v4.2.0](https://github.com/wireapp/wire-team-settings/releases/tag/v4.2.0) and image tag: 4.2.0-v0.28.28-1e2ef7 (#1856) +* Upgrade team settings to Release: [v4.3.0](https://github.com/wireapp/wire-team-settings/releases/tag/v4.3.0) and image tag: 4.3.0-v0.28.28-a2f11cf (#1950) * Upgrade Webapp to image tag: 20021-10-28-federation-m1 (#1856) ## API changes diff --git a/changelog.d/0-release-notes/minio-helm b/changelog.d/0-release-notes/minio-helm deleted file mode 100644 index ff40a316260..00000000000 --- a/changelog.d/0-release-notes/minio-helm +++ /dev/null @@ -1,3 +0,0 @@ -Breaking change to the `fake-aws-s3` (part of `fake-aws`) helm chart. We now use minio helm chart from https://charts.min.io. The options are documented [here](https://github.com/minio/minio/tree/master/helm/minio) (#1944) - -Before running the upgrade, the operators must use `kubectl edit deployment fake-aws-s3` and explicitly set `spec.template.spec.containers[0].serviceAccount` and `spec.template.spec.containers[0].serviceAccountName` to null. \ No newline at end of file diff --git a/changelog.d/0-release-notes/team-settings-upgrade b/changelog.d/0-release-notes/team-settings-upgrade deleted file mode 100644 index 3dc0dd5fc68..00000000000 --- a/changelog.d/0-release-notes/team-settings-upgrade +++ /dev/null @@ -1 +0,0 @@ -Upgrade team-settings version to 4.3.0-v0.28.28-a2f11cf diff --git a/changelog.d/0-release-notes/webapp-upgrade b/changelog.d/0-release-notes/webapp-upgrade deleted file mode 100644 index 1e2939ca294..00000000000 --- a/changelog.d/0-release-notes/webapp-upgrade +++ /dev/null @@ -1 +0,0 @@ -Upgrade webapp version to 2021-12-02-production.0-v0.28.29-0-ec2fa00 diff --git a/changelog.d/2-features/elasticsearch b/changelog.d/2-features/elasticsearch deleted file mode 100644 index d2d463ce624..00000000000 --- a/changelog.d/2-features/elasticsearch +++ /dev/null @@ -1 +0,0 @@ -By default install elasticsearch version 6.8.18 when using the elasticsearch-ephemeral chart \ No newline at end of file diff --git a/changelog.d/2-features/fluent-bit b/changelog.d/2-features/fluent-bit deleted file mode 100644 index 8c379fea833..00000000000 --- a/changelog.d/2-features/fluent-bit +++ /dev/null @@ -1 +0,0 @@ -Use fluent-bit chart from fluent.github.io instead of deprecated charts.helm.sh. Previous fluent-bit values are not compatible with the new chart, the documentation for the new chart can be found [here](https://github.com/fluent/helm-charts/tree/main/charts/fluent-bit) \ No newline at end of file diff --git a/changelog.d/2-features/kibana b/changelog.d/2-features/kibana deleted file mode 100644 index 1b718f01e3e..00000000000 --- a/changelog.d/2-features/kibana +++ /dev/null @@ -1 +0,0 @@ -Use kibana chart from helm.elastic.co instead of deprecated charts.helm.sh. Previous kibana values are not compatible with the new chart, the documentation for the new chart can be found [here](https://github.com/elastic/helm-charts/tree/main/kibana). This also upgrades kibana to version 6.8.18. diff --git a/changelog.d/2-features/metrics b/changelog.d/2-features/metrics deleted file mode 100644 index a4650c4123a..00000000000 --- a/changelog.d/2-features/metrics +++ /dev/null @@ -1 +0,0 @@ -Use kube-prometheus-stack instead of prometheus-operator and update grafana dashboards for compatibility and add federation endpoints to relevant queries. \ No newline at end of file diff --git a/changelog.d/2-features/structured-json-logs b/changelog.d/2-features/structured-json-logs deleted file mode 100644 index 841489cc6d0..00000000000 --- a/changelog.d/2-features/structured-json-logs +++ /dev/null @@ -1 +0,0 @@ -Add log format called 'StructuredJSON' for easier log aggregation \ No newline at end of file diff --git a/changelog.d/3-bug-fixes/elasticsearch-ephemeral-disable-auto-creation b/changelog.d/3-bug-fixes/elasticsearch-ephemeral-disable-auto-creation deleted file mode 100644 index b0189061d78..00000000000 --- a/changelog.d/3-bug-fixes/elasticsearch-ephemeral-disable-auto-creation +++ /dev/null @@ -1 +0,0 @@ -elasticsearch-ephemeral: Disable automatic creation of indices diff --git a/changelog.d/4-docs/changelog.d-docs b/changelog.d/4-docs/changelog.d-docs deleted file mode 100644 index 8308ed56ebb..00000000000 --- a/changelog.d/4-docs/changelog.d-docs +++ /dev/null @@ -1 +0,0 @@ -Document the wire-server PR process better. diff --git a/changelog.d/4-docs/fix-docs b/changelog.d/4-docs/fix-docs deleted file mode 100644 index 7cc610b9110..00000000000 --- a/changelog.d/4-docs/fix-docs +++ /dev/null @@ -1 +0,0 @@ -Remove documentation of unsupported scim end-point use case. \ No newline at end of file diff --git a/changelog.d/4-docs/servant.md b/changelog.d/4-docs/servant.md deleted file mode 100644 index 88e2b148dfd..00000000000 --- a/changelog.d/4-docs/servant.md +++ /dev/null @@ -1 +0,0 @@ -Document servant setup and combinators diff --git a/changelog.d/5-internal/in-mem-interpreters b/changelog.d/5-internal/in-mem-interpreters deleted file mode 100644 index 32d0dc0a454..00000000000 --- a/changelog.d/5-internal/in-mem-interpreters +++ /dev/null @@ -1 +0,0 @@ -Add in-memory interpreters for most Spar effects diff --git a/changelog.d/5-internal/minio-helm b/changelog.d/5-internal/minio-helm deleted file mode 100644 index d1dfc08a0bd..00000000000 --- a/changelog.d/5-internal/minio-helm +++ /dev/null @@ -1 +0,0 @@ -Use minio helm chart in fake-aws-s3 from charts.min.io instead of helm.min.io, the latter seems to be down \ No newline at end of file diff --git a/changelog.d/5-internal/polysemy-1.7.0.0 b/changelog.d/5-internal/polysemy-1.7.0.0 deleted file mode 100644 index 5bc5396e594..00000000000 --- a/changelog.d/5-internal/polysemy-1.7.0.0 +++ /dev/null @@ -1,2 +0,0 @@ -Upgrade to polysemy-1.7.0.0 - diff --git a/changelog.d/5-internal/polysemy-monad b/changelog.d/5-internal/polysemy-monad deleted file mode 100644 index eb00757ba05..00000000000 --- a/changelog.d/5-internal/polysemy-monad +++ /dev/null @@ -1 +0,0 @@ -Replace Galley monad with polysemy's Sem throughout Galley diff --git a/changelog.d/5-internal/split-eff2 b/changelog.d/5-internal/split-eff2 deleted file mode 100644 index 1ecf1d90eac..00000000000 --- a/changelog.d/5-internal/split-eff2 +++ /dev/null @@ -1 +0,0 @@ -Separate VerdictFormatStore effect from AReqIdStore effect diff --git a/changelog.d/6-federation/drop-grpc b/changelog.d/6-federation/drop-grpc deleted file mode 100644 index 2160c8b6a8f..00000000000 --- a/changelog.d/6-federation/drop-grpc +++ /dev/null @@ -1 +0,0 @@ -The server-to-server API now uses HTTP2 directly instead of gRPC diff --git a/changelog.d/6-federation/handle-leave-conversation-errors b/changelog.d/6-federation/handle-leave-conversation-errors deleted file mode 100644 index f6a0652966e..00000000000 --- a/changelog.d/6-federation/handle-leave-conversation-errors +++ /dev/null @@ -1 +0,0 @@ -Errors when leaving a conversation are now correctly handled instead of resulting in a generic federation error.