From 2ef0044cb55402ff240794ff1d8791ebfbac2f8d Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Mon, 24 Nov 2025 14:59:14 +0100 Subject: [PATCH 01/29] WPB-21964: Add Wire Meetings endpoints --- changelog.d/2-features/WPB-21964 | 1 + charts/background-worker/values.yaml | 9 + integration/integration.cabal | 1 + .../test/Test/FeatureFlags/PayingTeam.hs | 31 + integration/test/Test/FeatureFlags/Util.hs | 3 +- libs/galley-types/src/Galley/Types/Teams.hs | 7 + libs/wire-api/src/Wire/API/Conversation.hs | 5 +- libs/wire-api/src/Wire/API/Error/Galley.hs | 7 + libs/wire-api/src/Wire/API/Meeting.hs | 163 +++++ .../src/Wire/API/Routes/Internal/Galley.hs | 1 + .../src/Wire/API/Routes/Public/Galley.hs | 2 + .../Wire/API/Routes/Public/Galley/Feature.hs | 1 + .../Wire/API/Routes/Public/Galley/Meetings.hs | 128 ++++ libs/wire-api/src/Wire/API/Team/Feature.hs | 29 +- libs/wire-api/wire-api.cabal | 2 + .../20251122120000-meetings.sql | 26 + .../wire-subsystems/src/Wire/MeetingsStore.hs | 78 +++ .../src/Wire/MeetingsStore/Postgres.hs | 424 ++++++++++++ .../src/Wire/MeetingsSubsystem.hs | 70 ++ .../src/Wire/MeetingsSubsystem/Interpreter.hs | 318 +++++++++ libs/wire-subsystems/wire-subsystems.cabal | 4 + postgres-schema.sql | 59 ++ .../background-worker/background-worker.cabal | 2 + .../background-worker.integration.yaml | 6 + services/background-worker/default.nix | 2 + .../src/Wire/BackgroundWorker.hs | 8 +- .../src/Wire/BackgroundWorker/Options.hs | 12 + .../src/Wire/MeetingsCleanupWorker.hs | 139 ++++ services/galley/galley.cabal | 3 + .../postgresql-migrations/001_meetings.sql | 102 +++ services/galley/src/Galley/API/Create.hs | 34 +- services/galley/src/Galley/API/Internal.hs | 2 + services/galley/src/Galley/API/Meetings.hs | 185 +++++ .../galley/src/Galley/API/Public/Feature.hs | 1 + .../galley/src/Galley/API/Public/Meetings.hs | 33 + .../galley/src/Galley/API/Public/Servant.hs | 2 + .../galley/src/Galley/API/Teams/Features.hs | 2 + .../src/Galley/API/Teams/Features/Get.hs | 2 + services/galley/src/Galley/API/Util.hs | 108 +++ services/galley/src/Galley/App.hs | 6 + services/galley/src/Galley/Effects.hs | 8 +- services/galley/test/integration/API.hs | 2 + .../galley/test/integration/API/Meetings.hs | 653 ++++++++++++++++++ 43 files changed, 2647 insertions(+), 34 deletions(-) create mode 100644 changelog.d/2-features/WPB-21964 create mode 100644 integration/test/Test/FeatureFlags/PayingTeam.hs create mode 100644 libs/wire-api/src/Wire/API/Meeting.hs create mode 100644 libs/wire-api/src/Wire/API/Routes/Public/Galley/Meetings.hs create mode 100644 libs/wire-subsystems/postgres-migrations/20251122120000-meetings.sql create mode 100644 libs/wire-subsystems/src/Wire/MeetingsStore.hs create mode 100644 libs/wire-subsystems/src/Wire/MeetingsStore/Postgres.hs create mode 100644 libs/wire-subsystems/src/Wire/MeetingsSubsystem.hs create mode 100644 libs/wire-subsystems/src/Wire/MeetingsSubsystem/Interpreter.hs create mode 100644 services/background-worker/src/Wire/MeetingsCleanupWorker.hs create mode 100644 services/galley/postgresql-migrations/001_meetings.sql create mode 100644 services/galley/src/Galley/API/Meetings.hs create mode 100644 services/galley/src/Galley/API/Public/Meetings.hs create mode 100644 services/galley/test/integration/API/Meetings.hs diff --git a/changelog.d/2-features/WPB-21964 b/changelog.d/2-features/WPB-21964 new file mode 100644 index 0000000000..7209df76d6 --- /dev/null +++ b/changelog.d/2-features/WPB-21964 @@ -0,0 +1 @@ +Add payingTeam feature flag to distinguish paying teams from trial teams. Meetings created by paying team members are marked as non-trial. Public endpoints: GET/PUT /teams/:tid/features/payingTeam. Internal endpoints: GET/PUT/PATCH /i/teams/:tid/features/payingTeam and lock status management. diff --git a/charts/background-worker/values.yaml b/charts/background-worker/values.yaml index 57f3ce0070..c9c9a656bc 100644 --- a/charts/background-worker/values.yaml +++ b/charts/background-worker/values.yaml @@ -84,6 +84,15 @@ config: # Total attempts, including the first try maxAttempts: 3 + # Meetings cleanup configuration + meetingsCleanup: + # Delete meetings older than this many hours (48 hours = 2 days) + cleanOlderThanHours: 48 + # Maximum number of meetings to delete per batch + batchSize: 1000 + # Frequency in seconds to run the cleanup job (3600 = 1 hour) + cleanFrequencySeconds: 3600 + # Controls where conversation data is stored/accessed postgresMigration: conversation: postgresql diff --git a/integration/integration.cabal b/integration/integration.cabal index 03df02b438..96444950b2 100644 --- a/integration/integration.cabal +++ b/integration/integration.cabal @@ -157,6 +157,7 @@ library Test.FeatureFlags.MlsE2EId Test.FeatureFlags.MlsMigration Test.FeatureFlags.OutlookCalIntegration + Test.FeatureFlags.PayingTeam Test.FeatureFlags.SearchVisibilityAvailable Test.FeatureFlags.SearchVisibilityInbound Test.FeatureFlags.SelfDeletingMessages diff --git a/integration/test/Test/FeatureFlags/PayingTeam.hs b/integration/test/Test/FeatureFlags/PayingTeam.hs new file mode 100644 index 0000000000..e14d3cd6ad --- /dev/null +++ b/integration/test/Test/FeatureFlags/PayingTeam.hs @@ -0,0 +1,31 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2025 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.FeatureFlags.PayingTeam where + +import Test.FeatureFlags.Util +import Testlib.Prelude + +testPatchPayingTeam :: (HasCallStack) => App () +testPatchPayingTeam = checkPatch OwnDomain "payingTeam" disabled + +testPayingTeam :: (HasCallStack) => APIAccess -> App () +testPayingTeam access = + mkFeatureTests "payingTeam" + & addUpdate disabled + & addUpdate enabled + & runFeatureTests OwnDomain access diff --git a/integration/test/Test/FeatureFlags/Util.hs b/integration/test/Test/FeatureFlags/Util.hs index 3c7f617d8c..206cc30b70 100644 --- a/integration/test/Test/FeatureFlags/Util.hs +++ b/integration/test/Test/FeatureFlags/Util.hs @@ -240,7 +240,8 @@ defAllFeatures = "collabora" .= object ["edition" .= "COOL"], "storage" .= object ["teamQuotaBytes" .= "1000000000000"] ] - ] + ], + "payingTeam" .= disabled ] hasExplicitLockStatus :: String -> Bool diff --git a/libs/galley-types/src/Galley/Types/Teams.hs b/libs/galley-types/src/Galley/Types/Teams.hs index d63df1d3f7..cff0ca4838 100644 --- a/libs/galley-types/src/Galley/Types/Teams.hs +++ b/libs/galley-types/src/Galley/Types/Teams.hs @@ -330,6 +330,13 @@ newtype instance FeatureDefaults StealthUsersConfig deriving (FromJSON) via Defaults (LockableFeature StealthUsersConfig) deriving (ParseFeatureDefaults) via OptionalField StealthUsersConfig +newtype instance FeatureDefaults PayingTeamConfig + = PayingTeamDefaults (LockableFeature PayingTeamConfig) + deriving stock (Eq, Show) + deriving newtype (Default, GetFeatureDefaults) + deriving (FromJSON) via Defaults (LockableFeature PayingTeamConfig) + deriving (ParseFeatureDefaults) via OptionalField PayingTeamConfig + featureKey :: forall cfg. (IsFeatureConfig cfg) => Key.Key featureKey = Key.fromText $ featureName @cfg diff --git a/libs/wire-api/src/Wire/API/Conversation.hs b/libs/wire-api/src/Wire/API/Conversation.hs index 839d31fe01..eb84330a8d 100644 --- a/libs/wire-api/src/Wire/API/Conversation.hs +++ b/libs/wire-api/src/Wire/API/Conversation.hs @@ -840,7 +840,7 @@ instance PostgresMarshall ReceiptMode Int32 where -------------------------------------------------------------------------------- -- create -data GroupConvType = GroupConversation | Channel +data GroupConvType = GroupConversation | Channel | MeetingConversation deriving stock (Eq, Show, Generic, Enum) deriving (Arbitrary) via (GenericUniform GroupConvType) deriving (FromJSON, ToJSON, S.ToSchema) via Schema GroupConvType @@ -850,7 +850,8 @@ instance ToSchema GroupConvType where enum @Text "GroupConvType" $ mconcat [ element "group_conversation" GroupConversation, - element "channel" Channel + element "channel" Channel, + element "meeting" MeetingConversation ] instance C.Cql GroupConvType where diff --git a/libs/wire-api/src/Wire/API/Error/Galley.hs b/libs/wire-api/src/Wire/API/Error/Galley.hs index 540f6391cb..198ac6060b 100644 --- a/libs/wire-api/src/Wire/API/Error/Galley.hs +++ b/libs/wire-api/src/Wire/API/Error/Galley.hs @@ -177,6 +177,8 @@ data GalleyError | NotAnMlsConversation | MLSReadReceiptsNotAllowed | MLSInvalidLeafNodeSignature + | -- Meeting errors + MeetingNotFound deriving (Show, Eq, Generic) deriving (FromJSON, ToJSON) via (CustomEncoded GalleyError) @@ -375,6 +377,11 @@ type instance MapError 'MLSReadReceiptsNotAllowed = 'StaticError 403 "mls-receip type instance MapError 'MLSInvalidLeafNodeSignature = 'StaticError 400 "mls-invalid-leaf-node-signature" "Invalid leaf node signature" +-------------------------------------------------------------------------------- +-- Meeting errors + +type instance MapError 'MeetingNotFound = 'StaticError 404 "meeting-not-found" "Meeting not found" + -------------------------------------------------------------------------------- -- Team Member errors diff --git a/libs/wire-api/src/Wire/API/Meeting.hs b/libs/wire-api/src/Wire/API/Meeting.hs new file mode 100644 index 0000000000..0a4cbb45b9 --- /dev/null +++ b/libs/wire-api/src/Wire/API/Meeting.hs @@ -0,0 +1,163 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2025 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.Meeting where + +import Control.Lens ((?~)) +import Data.Aeson () +import Data.Id (ConvId, UserId, uuidSchema) +import Data.Json.Util (utcTimeSchema) +import Data.OpenApi qualified as S +import Data.Qualified (Qualified, qualifiedSchema) +import Data.Schema +import Data.Time.Clock +import Data.UUID (UUID) +import Deriving.Aeson +import Imports +import Servant (FromHttpApiData, ToHttpApiData) +import Wire.API.User.Identity (EmailAddress) +import Wire.Arbitrary (Arbitrary, GenericUniform (..)) + +-- | Unique identifier for a meeting +newtype MeetingId = MeetingId {unMeetingId :: UUID} + deriving stock (Eq, Ord, Show, Generic) + deriving newtype (ToJSON, FromJSON, FromHttpApiData, ToHttpApiData, S.ToSchema, S.ToParamSchema) + deriving (Arbitrary) via (GenericUniform MeetingId) + +instance ToSchema MeetingId where + schema = MeetingId <$> unMeetingId .= uuidSchema + +instance ToSchema (Qualified MeetingId) where + schema = qualifiedSchema "MeetingId" "id" schema + +-- | Core Meeting type +data Meeting = Meeting + { id :: Qualified MeetingId, + title :: Text, + creator :: Qualified UserId, + startDate :: UTCTime, + endDate :: UTCTime, + recurrence :: Maybe Recurrence, + conversationId :: Qualified ConvId, + invitedEmails :: [EmailAddress], + trial :: Bool + } + deriving stock (Eq, Show, Generic) + deriving (ToJSON, FromJSON, S.ToSchema) via (Schema Meeting) + deriving (Arbitrary) via (GenericUniform Meeting) + +instance ToSchema Meeting where + schema = + objectWithDocModifier "Meeting" (description ?~ "A scheduled meeting") $ + Meeting + <$> (.id) .= field "qualified_id" schema + <*> (.title) .= field "title" schema + <*> (.creator) .= field "qualified_creator" schema + <*> (.startDate) .= field "start_date" utcTimeSchema + <*> (.endDate) .= field "end_date" utcTimeSchema + <*> (.recurrence) .= maybe_ (optField "recurrence" schema) + <*> (.conversationId) .= field "qualified_conversation" schema + <*> (.invitedEmails) .= field "invited_emails" (array schema) + <*> (.trial) .= field "trial" schema + +-- | Request to create a new meeting +data NewMeeting = NewMeeting + { startDate :: UTCTime, + endDate :: UTCTime, + recurrence :: Maybe Recurrence, + title :: Text, + invitedEmails :: [EmailAddress] + } + deriving stock (Eq, Show, Generic) + deriving (ToJSON, FromJSON, S.ToSchema) via (Schema NewMeeting) + deriving (Arbitrary) via (GenericUniform NewMeeting) + +data Recurrence = Recurrence + { freq :: Frequency, + interval :: Maybe Int, + until :: Maybe UTCTime + } + deriving stock (Eq, Show, Generic) + deriving (ToJSON, FromJSON, S.ToSchema) via (Schema Recurrence) + deriving (Arbitrary) via (GenericUniform Recurrence) + +data Frequency = Daily | Weekly | Monthly | Yearly + deriving stock (Eq, Show, Generic) + deriving (ToJSON, FromJSON, S.ToSchema) via (Schema Frequency) + deriving (Arbitrary) via (GenericUniform Frequency) + +instance ToSchema NewMeeting where + schema = + objectWithDocModifier "NewMeeting" (description ?~ "Request to create a new meeting") $ + NewMeeting + <$> (.startDate) .= field "start_date" utcTimeSchema + <*> (.endDate) .= field "end_date" utcTimeSchema + <*> (.recurrence) .= maybe_ (optField "recurrence" schema) + <*> (.title) .= field "title" schema + <*> (.invitedEmails) .= (fromMaybe [] <$> optField "invited_emails" (array schema)) + +-- | Request to update an existing meeting +data UpdateMeeting = UpdateMeeting + { startDate :: Maybe UTCTime, + endDate :: Maybe UTCTime, + title :: Maybe Text, + recurrence :: Maybe Recurrence + } + deriving stock (Eq, Show, Generic) + deriving (ToJSON, FromJSON, S.ToSchema) via (Schema UpdateMeeting) + deriving (Arbitrary) via (GenericUniform UpdateMeeting) + +instance ToSchema UpdateMeeting where + schema = + objectWithDocModifier "UpdateMeeting" (description ?~ "Request to update a meeting") $ + UpdateMeeting + <$> (.startDate) .= maybe_ (optField "start_date" utcTimeSchema) + <*> (.endDate) .= maybe_ (optField "end_date" utcTimeSchema) + <*> (.title) .= maybe_ (optField "title" schema) + <*> (.recurrence) .= maybe_ (optField "recurrence" schema) + +instance ToSchema Frequency where + schema = + enum @Text "Frequency" $ + mconcat + [ element "Daily" Daily, + element "Weekly" Weekly, + element "Monthly" Monthly, + element "Yearly" Yearly + ] + +instance ToSchema Recurrence where + schema = + objectWithDocModifier "Recurrence" (description ?~ "Recurrence pattern for meetings") $ + Recurrence + <$> (.freq) .= field "frequency" schema + <*> (.interval) .= maybe_ (optField "interval" schema) + <*> (.until) .= maybe_ (optField "until" utcTimeSchema) + +-- | Request to add/remove invited email +newtype MeetingEmailsInvitation = MeetingEmailsInvitation + { emails :: [EmailAddress] + } + deriving stock (Eq, Show, Generic) + deriving (ToJSON, FromJSON, S.ToSchema) via (Schema MeetingEmailsInvitation) + deriving (Arbitrary) via (GenericUniform MeetingEmailsInvitation) + +instance ToSchema MeetingEmailsInvitation where + schema = + objectWithDocModifier "MeetingEmailsInvitation" (description ?~ "Emails invitation") $ + MeetingEmailsInvitation + <$> (.emails) .= field "emails" (array schema) diff --git a/libs/wire-api/src/Wire/API/Routes/Internal/Galley.hs b/libs/wire-api/src/Wire/API/Routes/Internal/Galley.hs index 6dedd4ccdd..74163616c0 100644 --- a/libs/wire-api/src/Wire/API/Routes/Internal/Galley.hs +++ b/libs/wire-api/src/Wire/API/Routes/Internal/Galley.hs @@ -94,6 +94,7 @@ type IFeatureAPI = :<|> IFeatureStatusLockStatusPut AppsConfig :<|> IFeatureStatusLockStatusPut SimplifiedUserConnectionRequestQRCodeConfig :<|> IFeatureStatusLockStatusPut StealthUsersConfig + :<|> IFeatureStatusLockStatusPut PayingTeamConfig -- all feature configs :<|> Named "feature-configs-internal" 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 e761006877..d7ab4e3c84 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs @@ -29,6 +29,7 @@ import Wire.API.Routes.Public.Galley.CustomBackend import Wire.API.Routes.Public.Galley.Feature import Wire.API.Routes.Public.Galley.LegalHold import Wire.API.Routes.Public.Galley.MLS +import Wire.API.Routes.Public.Galley.Meetings import Wire.API.Routes.Public.Galley.Messaging import Wire.API.Routes.Public.Galley.Team import Wire.API.Routes.Public.Galley.TeamConversation @@ -43,6 +44,7 @@ type GalleyAPI = :<|> TeamAPI :<|> FeatureAPI :<|> MLSAPI + :<|> MeetingsAPI :<|> CustomBackendAPI :<|> LegalHoldAPI :<|> TeamMemberAPI diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Galley/Feature.hs b/libs/wire-api/src/Wire/API/Routes/Public/Galley/Feature.hs index d0c02b3412..4b83700692 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Galley/Feature.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Galley/Feature.hs @@ -78,6 +78,7 @@ type FeatureAPI = :<|> FeatureAPIGet SimplifiedUserConnectionRequestQRCodeConfig :<|> FeatureAPIGet StealthUsersConfig :<|> FeatureAPIGet CellsInternalConfig + :<|> FeatureAPIGetPut PayingTeamConfig type VersionedFeatureAPIPut named reqBodyVersion cfg = Named diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Galley/Meetings.hs b/libs/wire-api/src/Wire/API/Routes/Public/Galley/Meetings.hs new file mode 100644 index 0000000000..c5fd3fe999 --- /dev/null +++ b/libs/wire-api/src/Wire/API/Routes/Public/Galley/Meetings.hs @@ -0,0 +1,128 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2025 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.Routes.Public.Galley.Meetings where + +import Data.Domain (Domain) +import Servant +import Wire.API.Error +import Wire.API.Error.Galley +import Wire.API.Meeting +import Wire.API.Routes.MultiVerb +import Wire.API.Routes.Named +import Wire.API.Routes.Public + +type MeetingsAPI = + Named + "create-meeting" + ( Summary "Create a new meeting" + :> ZLocalUser + :> "meetings" + :> ReqBody '[JSON] NewMeeting + :> CanThrow 'InvalidOperation + :> CanThrow UnreachableBackends + :> MultiVerb + 'POST + '[JSON] + '[Respond 201 "Meeting created" Meeting] + Meeting + ) + :<|> Named + "list-meetings" + ( Summary "List all meetings for the authenticated user" + :> ZLocalUser + :> "meetings" + :> "list" + :> Get '[JSON] [Meeting] + ) + :<|> Named + "get-meeting" + ( Summary "Get a single meeting by ID" + :> ZLocalUser + :> "meetings" + :> Capture "domain" Domain + :> Capture "id" MeetingId + :> CanThrow 'MeetingNotFound + :> Get '[JSON] Meeting + ) + :<|> Named + "update-meeting" + ( Summary "Update an existing meeting" + :> ZLocalUser + :> "meetings" + :> Capture "domain" Domain + :> Capture "id" MeetingId + :> CanThrow 'MeetingNotFound + :> CanThrow 'AccessDenied + :> CanThrow 'InvalidOperation + :> ReqBody '[JSON] UpdateMeeting + :> MultiVerb + 'PUT + '[JSON] + '[Respond 200 "Meeting updated" Meeting] + Meeting + ) + :<|> Named + "delete-meeting" + ( Summary "Delete a meeting" + :> ZLocalUser + :> "meetings" + :> Capture "domain" Domain + :> Capture "id" MeetingId + :> CanThrow 'MeetingNotFound + :> CanThrow 'AccessDenied + :> MultiVerb + 'DELETE + '[JSON] + '[RespondEmpty 200 "Meeting deleted"] + () + ) + :<|> Named + "add-meeting-invitation" + ( Summary "Add an email to the invited emails" + :> ZLocalUser + :> "meetings" + :> Capture "domain" Domain + :> Capture "id" MeetingId + :> "invitations" + :> CanThrow 'MeetingNotFound + :> CanThrow 'AccessDenied + :> ReqBody '[JSON] MeetingEmailsInvitation + :> MultiVerb + 'POST + '[JSON] + '[RespondEmpty 200 "Invitation added"] + () + ) + :<|> Named + "remove-meeting-invitation" + ( Summary "Remove emails from the invited emails" + :> ZLocalUser + :> "meetings" + :> Capture "domain" Domain + :> Capture "id" MeetingId + :> "invitations" + :> "delete" + :> CanThrow 'MeetingNotFound + :> CanThrow 'AccessDenied + :> ReqBody '[JSON] MeetingEmailsInvitation + :> MultiVerb + 'POST + '[JSON] + '[RespondEmpty 200 "Invitations removed"] + () + ) diff --git a/libs/wire-api/src/Wire/API/Team/Feature.hs b/libs/wire-api/src/Wire/API/Team/Feature.hs index 0e323507d4..a982769840 100644 --- a/libs/wire-api/src/Wire/API/Team/Feature.hs +++ b/libs/wire-api/src/Wire/API/Team/Feature.hs @@ -111,6 +111,7 @@ module Wire.API.Team.Feature AppsConfig (..), SimplifiedUserConnectionRequestQRCodeConfig (..), StealthUsersConfig (..), + PayingTeamConfig (..), Features, AllFeatures, NpProject (..), @@ -275,6 +276,7 @@ data FeatureSingleton cfg where FeatureSingletonAssetAuditLogConfig :: FeatureSingleton AssetAuditLogConfig FeatureSingletonStealthUsersConfig :: FeatureSingleton StealthUsersConfig FeatureSingletonCellsInternalConfig :: FeatureSingleton CellsInternalConfig + FeatureSingletonPayingTeamConfig :: FeatureSingleton PayingTeamConfig type family DeprecatedFeatureName (v :: Version) (cfg :: Type) :: Symbol @@ -2049,6 +2051,30 @@ instance IsFeatureConfig StealthUsersConfig where type FeatureSymbol StealthUsersConfig = "stealthUsers" featureSingleton = FeatureSingletonStealthUsersConfig +-------------------------------------------------------------------------------- +-- PayingTeam Feature +-- +-- Indicates whether a team is a paying customer. When enabled, meetings created +-- by team members are not marked as trial. When disabled, meetings are trial. + +data PayingTeamConfig = PayingTeamConfig + deriving (Eq, Show, Generic, GSOP.Generic) + deriving (Arbitrary) via (GenericUniform PayingTeamConfig) + deriving (RenderableSymbol) via (RenderableTypeName PayingTeamConfig) + deriving (ParseDbFeature, Default) via TrivialFeature PayingTeamConfig + +instance ToSchema PayingTeamConfig where + schema = object "PayingTeamConfig" objectSchema + +instance Default (LockableFeature PayingTeamConfig) where + def = defUnlockedFeature + +instance IsFeatureConfig PayingTeamConfig where + type FeatureSymbol PayingTeamConfig = "payingTeam" + featureSingleton = FeatureSingletonPayingTeamConfig + + objectSchema = pure PayingTeamConfig + --------------------------------------------------------------------------------- -- FeatureStatus @@ -2142,7 +2168,8 @@ type Features = SimplifiedUserConnectionRequestQRCodeConfig, AssetAuditLogConfig, StealthUsersConfig, - CellsInternalConfig + CellsInternalConfig, + PayingTeamConfig ] -- | list of available features as a record diff --git a/libs/wire-api/wire-api.cabal b/libs/wire-api/wire-api.cabal index 80c4e21136..0991b6215f 100644 --- a/libs/wire-api/wire-api.cabal +++ b/libs/wire-api/wire-api.cabal @@ -112,6 +112,7 @@ library Wire.API.Internal.BulkPush Wire.API.Internal.Notification Wire.API.Locale + Wire.API.Meeting Wire.API.Message Wire.API.Message.Proto Wire.API.MLS.AuthenticatedContent @@ -205,6 +206,7 @@ library Wire.API.Routes.Public.Galley.CustomBackend Wire.API.Routes.Public.Galley.Feature Wire.API.Routes.Public.Galley.LegalHold + Wire.API.Routes.Public.Galley.Meetings Wire.API.Routes.Public.Galley.Messaging Wire.API.Routes.Public.Galley.MLS Wire.API.Routes.Public.Galley.Team diff --git a/libs/wire-subsystems/postgres-migrations/20251122120000-meetings.sql b/libs/wire-subsystems/postgres-migrations/20251122120000-meetings.sql new file mode 100644 index 0000000000..c1ddfa8e55 --- /dev/null +++ b/libs/wire-subsystems/postgres-migrations/20251122120000-meetings.sql @@ -0,0 +1,26 @@ +-- Wire Meetings table +-- Create meetings table for storing scheduled meetings + +CREATE TABLE IF NOT EXISTS meetings ( + id UUID NOT NULL, + domain TEXT NOT NULL, + title TEXT NOT NULL, + creator UUID NOT NULL, + creator_domain TEXT NOT NULL, + start_date TIMESTAMPTZ NOT NULL, + end_date TIMESTAMPTZ NOT NULL, + recurrence JSONB, + conversation_id UUID NOT NULL, + conversation_domain TEXT NOT NULL, + invited_emails TEXT[] DEFAULT '{}', + trial BOOLEAN DEFAULT FALSE, + created_at TIMESTAMPTZ DEFAULT NOW(), + updated_at TIMESTAMPTZ DEFAULT NOW(), + PRIMARY KEY (domain, id) +); + +-- Indexes for common queries +CREATE INDEX IF NOT EXISTS idx_meetings_creator ON meetings(creator); +CREATE INDEX IF NOT EXISTS idx_meetings_conversation ON meetings(conversation_id, conversation_domain); +CREATE INDEX IF NOT EXISTS idx_meetings_start_date ON meetings(start_date); +CREATE INDEX IF NOT EXISTS idx_meetings_end_date ON meetings(end_date); diff --git a/libs/wire-subsystems/src/Wire/MeetingsStore.hs b/libs/wire-subsystems/src/Wire/MeetingsStore.hs new file mode 100644 index 0000000000..ceb3c6463b --- /dev/null +++ b/libs/wire-subsystems/src/Wire/MeetingsStore.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2025 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.MeetingsStore where + +import Data.Id +import Data.Qualified +import Data.Time.Clock +import Imports +import Polysemy +import Wire.API.Meeting +import Wire.API.User.Identity (EmailAddress) + +data MeetingsStore m a where + CreateMeeting :: + Qualified MeetingId -> + Qualified UserId -> + Text -> + UTCTime -> + UTCTime -> + Maybe Recurrence -> + Qualified ConvId -> + [EmailAddress] -> + Bool -> + MeetingsStore m () + GetMeeting :: + Qualified MeetingId -> + MeetingsStore m (Maybe Meeting) + ListMeetingsByUser :: + UserId -> + MeetingsStore m [Meeting] + ListMeetingsByConversation :: + Qualified ConvId -> + MeetingsStore m [Meeting] + UpdateMeeting :: + Qualified MeetingId -> + Maybe Text -> + Maybe UTCTime -> + Maybe UTCTime -> + Maybe Recurrence -> + MeetingsStore m (Maybe Meeting) + DeleteMeeting :: + Qualified MeetingId -> + MeetingsStore m () + AddInvitedEmails :: + Qualified MeetingId -> + [EmailAddress] -> + MeetingsStore m () + RemoveInvitedEmails :: + Qualified MeetingId -> + [EmailAddress] -> + MeetingsStore m () + -- Cleanup operations + GetOldMeetings :: + UTCTime -> + Int -> + MeetingsStore m [Meeting] + DeleteMeetingBatch :: + [Qualified MeetingId] -> + MeetingsStore m Int64 + +makeSem ''MeetingsStore diff --git a/libs/wire-subsystems/src/Wire/MeetingsStore/Postgres.hs b/libs/wire-subsystems/src/Wire/MeetingsStore/Postgres.hs new file mode 100644 index 0000000000..84a85d6b61 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/MeetingsStore/Postgres.hs @@ -0,0 +1,424 @@ +{-# LANGUAGE RecordWildCards #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2025 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.MeetingsStore.Postgres + ( interpretMeetingsStoreToPostgres, + ) +where + +import Data.Aeson (Result (Success), Value, fromJSON, toJSON) +import Data.Domain (Domain (..), _domainText) +import Data.Id +import Data.Profunctor (dimap) +import Data.Qualified +import Data.Time.Clock +import Data.UUID (UUID) +import Data.UUID qualified as UUID +import Data.Vector qualified as V +import Hasql.Pool +import Hasql.Session +import Hasql.Statement +import Hasql.TH +import Imports +import Polysemy +import Polysemy.Error (Error, throw) +import Polysemy.Input +import Wire.API.Meeting qualified as API +import Wire.API.User.Identity (EmailAddress, emailAddressText, fromEmail) +import Wire.MeetingsStore + +interpretMeetingsStoreToPostgres :: + ( Member (Embed IO) r, + Member (Input Pool) r, + Member (Error UsageError) r + ) => + InterpreterFor MeetingsStore r +interpretMeetingsStoreToPostgres = + interpret $ \case + CreateMeeting meetingId creator title startDate endDate schedule convId emails trial -> + createMeetingImpl meetingId creator title startDate endDate schedule convId emails trial + GetMeeting meetingId -> + getMeetingImpl meetingId + ListMeetingsByUser userId -> + listMeetingsByUserImpl userId + ListMeetingsByConversation convId -> + listMeetingsByConversationImpl convId + UpdateMeeting meetingId title startDate endDate schedule -> + updateMeetingImpl meetingId title startDate endDate schedule + DeleteMeeting meetingId -> + deleteMeetingImpl meetingId + AddInvitedEmails meetingId email -> + addInvitedEmailsImpl meetingId email + RemoveInvitedEmails meetingId emails -> + removeInvitedEmailsImpl meetingId emails + GetOldMeetings cutoffTime batchSize -> + getOldMeetingsImpl cutoffTime batchSize + DeleteMeetingBatch meetingIds -> + deleteMeetingBatchImpl meetingIds + +createMeetingImpl :: + ( Member (Input Pool) r, + Member (Embed IO) r, + Member (Error UsageError) r + ) => + Qualified API.MeetingId -> + Qualified UserId -> + Text -> + UTCTime -> + UTCTime -> + Maybe API.Recurrence -> + Qualified ConvId -> + [EmailAddress] -> + Bool -> + Sem r () +createMeetingImpl qMeetingId qCreator title startDate endDate recurrence qConvId emails trial = do + pool <- input + result <- liftIO $ use pool session + either throw pure result + where + session :: Session () + session = statement params insertStatement + + params = + ( UUID.toText (API.unMeetingId (qUnqualified qMeetingId)), + _domainText (qDomain qMeetingId), + title, + toUUID (qUnqualified qCreator), + _domainText (qDomain qCreator), + startDate, + endDate, + fmap toJSON recurrence, + toUUID (qUnqualified qConvId), + _domainText (qDomain qConvId), + V.fromList (map fromEmail emails), + trial + ) + + insertStatement :: Statement (Text, Text, Text, UUID.UUID, Text, UTCTime, UTCTime, Maybe Value, UUID.UUID, Text, V.Vector Text, Bool) () + insertStatement = + [resultlessStatement| + INSERT INTO meetings + (id, domain, title, creator, creator_domain, start_date, end_date, recurrence, + conversation_id, conversation_domain, invited_emails, trial) + VALUES + ($1 :: text :: uuid, $2 :: text, $3 :: text, $4 :: uuid, $5 :: text, $6 :: timestamptz, + $7 :: timestamptz, $8 :: jsonb?, $9 :: uuid, $10 :: text, $11 :: text[], $12 :: boolean) + |] + +getMeetingImpl :: + ( Member (Input Pool) r, + Member (Embed IO) r, + Member (Error UsageError) r + ) => + Qualified API.MeetingId -> + Sem r (Maybe API.Meeting) +getMeetingImpl qMeetingId = do + pool <- input + result <- liftIO $ use pool session + either throw pure result + where + session :: Session (Maybe API.Meeting) + session = statement (_domainText (qDomain qMeetingId), UUID.toText (API.unMeetingId (qUnqualified qMeetingId))) getMeetingStatement + + getMeetingStatement :: Statement (Text, Text) (Maybe API.Meeting) + getMeetingStatement = + dimap + Imports.id + (fmap rowToMeeting) + $ [maybeStatement| + SELECT id :: text :: uuid, domain :: text, title :: text, creator :: uuid, creator_domain :: text, + start_date :: timestamptz, end_date :: timestamptz, recurrence :: jsonb?, + conversation_id :: uuid, conversation_domain :: text, + invited_emails :: text[], trial :: boolean + FROM meetings + WHERE domain = ($1 :: text) AND id :: text = ($2 :: text) + |] + +listMeetingsByUserImpl :: + ( Member (Input Pool) r, + Member (Embed IO) r, + Member (Error UsageError) r + ) => + UserId -> + Sem r [API.Meeting] +listMeetingsByUserImpl userId = do + pool <- input + result <- liftIO $ use pool session + either throw pure result + where + session :: Session [API.Meeting] + session = statement (toUUID userId) listStatement + + listStatement :: Statement UUID.UUID [API.Meeting] + listStatement = + dimap + Imports.id + (V.toList . fmap rowToMeeting) + $ [vectorStatement| + SELECT id :: text :: uuid, domain :: text, title :: text, creator :: uuid, creator_domain :: text, + start_date :: timestamptz, end_date :: timestamptz, recurrence :: jsonb?, + conversation_id :: uuid, conversation_domain :: text, + invited_emails :: text[], trial :: boolean + FROM meetings + WHERE creator = ($1 :: uuid) + ORDER BY start_date ASC + |] + +listMeetingsByConversationImpl :: + ( Member (Input Pool) r, + Member (Embed IO) r, + Member (Error UsageError) r + ) => + Qualified ConvId -> + Sem r [API.Meeting] +listMeetingsByConversationImpl qConvId = do + pool <- input + result <- liftIO $ use pool session + either throw pure result + where + session :: Session [API.Meeting] + session = statement (toUUID (qUnqualified qConvId), _domainText (qDomain qConvId)) listStatement + + listStatement :: Statement (UUID.UUID, Text) [API.Meeting] + listStatement = + dimap + Imports.id + (V.toList . fmap rowToMeeting) + $ [vectorStatement| + SELECT id :: text :: uuid, domain :: text, title :: text, creator :: uuid, creator_domain :: text, + start_date :: timestamptz, end_date :: timestamptz, recurrence :: jsonb?, + conversation_id :: uuid, conversation_domain :: text, + invited_emails :: text[], trial :: boolean + FROM meetings + WHERE conversation_id = ($1 :: uuid) AND conversation_domain = ($2 :: text) + ORDER BY start_date ASC + |] + +updateMeetingImpl :: + ( Member (Input Pool) r, + Member (Embed IO) r, + Member (Error UsageError) r + ) => + Qualified API.MeetingId -> + Maybe Text -> + Maybe UTCTime -> + Maybe UTCTime -> + Maybe API.Recurrence -> + Sem r (Maybe API.Meeting) +updateMeetingImpl qMeetingId mTitle mStartDate mEndDate mRecurrence = do + pool <- input + result <- liftIO $ use pool session + either throw pure result + where + session :: Session (Maybe API.Meeting) + session = do + statement + ( mTitle, + mStartDate, + mEndDate, + fmap toJSON mRecurrence, + _domainText (qDomain qMeetingId), + UUID.toText (API.unMeetingId (qUnqualified qMeetingId)) + ) + updateStatement + statement (_domainText (qDomain qMeetingId), UUID.toText (API.unMeetingId (qUnqualified qMeetingId))) getMeetingStatement + + updateStatement :: Statement (Maybe Text, Maybe UTCTime, Maybe UTCTime, Maybe Value, Text, Text) () + updateStatement = + [resultlessStatement| + UPDATE meetings + SET title = COALESCE($1 :: text?, title), + start_date = COALESCE($2 :: timestamptz?, start_date), + end_date = COALESCE($3 :: timestamptz?, end_date), + recurrence = COALESCE($4 :: jsonb?, recurrence) + WHERE domain = ($5 :: text) AND id :: text = ($6 :: text) + |] + + getMeetingStatement :: Statement (Text, Text) (Maybe API.Meeting) + getMeetingStatement = + dimap + Imports.id + (fmap rowToMeeting) + $ [maybeStatement| + SELECT id :: text :: uuid, domain :: text, title :: text, creator :: uuid, creator_domain :: text, + start_date :: timestamptz, end_date :: timestamptz, recurrence :: jsonb?, + conversation_id :: uuid, conversation_domain :: text, + invited_emails :: text[], trial :: boolean + FROM meetings + WHERE domain = ($1 :: text) AND id :: text = ($2 :: text) + |] + +deleteMeetingImpl :: + ( Member (Input Pool) r, + Member (Embed IO) r, + Member (Error UsageError) r + ) => + Qualified API.MeetingId -> + Sem r () +deleteMeetingImpl qMeetingId = do + pool <- input + result <- liftIO $ use pool session + either throw pure result + where + session :: Session () + session = statement (_domainText (qDomain qMeetingId), UUID.toText (API.unMeetingId (qUnqualified qMeetingId))) deleteStatement + + deleteStatement :: Statement (Text, Text) () + deleteStatement = + [resultlessStatement| + DELETE FROM meetings + WHERE domain = ($1 :: text) AND id :: text = ($2 :: text) + |] + +addInvitedEmailsImpl :: + ( Member (Input Pool) r, + Member (Embed IO) r, + Member (Error UsageError) r + ) => + Qualified API.MeetingId -> + [EmailAddress] -> + Sem r () +addInvitedEmailsImpl qMeetingId emails = do + pool <- input + result <- liftIO $ use pool session + either throw pure result + where + session :: Session () + session = statement (V.fromList (fromEmail <$> emails), _domainText (qDomain qMeetingId), UUID.toText (API.unMeetingId (qUnqualified qMeetingId))) addEmailStatement + + addEmailStatement :: Statement (V.Vector Text, Text, Text) () + addEmailStatement = + [resultlessStatement| + UPDATE meetings + SET invited_emails = array_cat(invited_emails, $1 :: text[]) + WHERE domain = ($2 :: text) AND id :: text = ($3 :: text) + |] + +removeInvitedEmailsImpl :: + ( Member (Input Pool) r, + Member (Embed IO) r, + Member (Error UsageError) r + ) => + Qualified API.MeetingId -> + [EmailAddress] -> + Sem r () +removeInvitedEmailsImpl qMeetingId emails = do + pool <- input + result <- liftIO $ use pool session + either throw pure result + where + session :: Session () + session = statement (V.fromList (fromEmail <$> emails), _domainText (qDomain qMeetingId), UUID.toText (API.unMeetingId (qUnqualified qMeetingId))) removeEmailStatement + + removeEmailStatement :: Statement (V.Vector Text, Text, Text) () + removeEmailStatement = + [resultlessStatement| + UPDATE meetings M + SET invited_emails = (SELECT array(SELECT unnest(M.invited_emails) EXCEPT SELECT unnest($1 :: text[]))) + WHERE domain = ($2 :: text) AND id :: text = ($3 :: text) + |] + +getOldMeetingsImpl :: + ( Member (Input Pool) r, + Member (Embed IO) r, + Member (Error UsageError) r + ) => + UTCTime -> + Int -> + Sem r [API.Meeting] +getOldMeetingsImpl cutoffTime batchSize = do + pool <- input + result <- liftIO $ use pool session + either throw pure result + where + session :: Session [API.Meeting] + session = statement (cutoffTime, fromIntegral batchSize) getOldStatement + + getOldStatement :: Statement (UTCTime, Int32) [API.Meeting] + getOldStatement = + dimap + id + (fmap rowToMeeting . V.toList) + [vectorStatement| + SELECT id :: uuid, domain :: text, title :: text, creator :: uuid, creator_domain :: text, + start_date :: timestamptz, end_date :: timestamptz, recurrence :: jsonb?, + conversation_id :: uuid, conversation_domain :: text, + invited_emails :: text[], trial :: bool + FROM meetings + WHERE end_date < ($1 :: timestamptz) + ORDER BY end_date ASC + LIMIT ($2 :: int4) + |] + +deleteMeetingBatchImpl :: + ( Member (Input Pool) r, + Member (Embed IO) r, + Member (Error UsageError) r + ) => + [Qualified API.MeetingId] -> + Sem r Int64 +deleteMeetingBatchImpl meetingIds = do + pool <- input + result <- liftIO $ use pool session + either throw pure result + where + session :: Session Int64 + session = foldM deleteSingle 0 meetingIds + + deleteSingle :: Int64 -> Qualified API.MeetingId -> Session Int64 + deleteSingle acc qMeetingId = do + count <- statement (UUID.toText (API.unMeetingId (qUnqualified qMeetingId)), _domainText (qDomain qMeetingId)) deleteStatement + pure (acc + count) + + deleteStatement :: Statement (Text, Text) Int64 + deleteStatement = + [rowsAffectedStatement| + DELETE FROM meetings + WHERE id :: text = ($1 :: text) AND domain = ($2 :: text) + |] + +-- Helper functions + +rowToMeeting :: (UUID, Text, Text, UUID, Text, UTCTime, UTCTime, Maybe Value, UUID, Text, V.Vector Text, Bool) -> API.Meeting +rowToMeeting (meetingIdUUID, domainText_, titleText, creatorUUID, creatorDomainText, startDate', endDate', recurrenceJSON, convIdUUID, convDomainText, emailsVec, trial') = + let meetingId' = API.MeetingId meetingIdUUID + domain' = Domain domainText_ + qMeetingId = Qualified meetingId' domain' + creator' = Id creatorUUID + creatorDomain' = Domain creatorDomainText + qCreator = Qualified creator' creatorDomain' + convId' = Id convIdUUID + convDomain' = Domain convDomainText + qConvId = Qualified convId' convDomain' + emails' = mapMaybe emailAddressText (V.toList emailsVec) + recurrence' = + recurrenceJSON >>= \v -> case fromJSON v of + Success r -> Just r + _ -> Nothing + in API.Meeting + { API.id = qMeetingId, + API.title = titleText, + API.creator = qCreator, + API.startDate = startDate', + API.endDate = endDate', + API.recurrence = recurrence', + API.conversationId = qConvId, + API.invitedEmails = emails', + API.trial = trial' + } diff --git a/libs/wire-subsystems/src/Wire/MeetingsSubsystem.hs b/libs/wire-subsystems/src/Wire/MeetingsSubsystem.hs new file mode 100644 index 0000000000..57bf1f5d2a --- /dev/null +++ b/libs/wire-subsystems/src/Wire/MeetingsSubsystem.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2025 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.MeetingsSubsystem where + +import Data.Id +import Data.Qualified +import Data.Time.Clock (UTCTime) +import Imports +import Polysemy +import Wire.API.Meeting +import Wire.API.User.Identity (EmailAddress) +import Wire.StoredConversation (StoredConversation) + +data MeetingsSubsystem m a where + CreateMeeting :: + Local UserId -> + NewMeeting -> + -- | trial: True if this is a trial meeting + Bool -> + MeetingsSubsystem m (Meeting, StoredConversation) + GetMeeting :: + Local UserId -> + Qualified MeetingId -> + MeetingsSubsystem m (Maybe Meeting) + ListMeetings :: + Local UserId -> + MeetingsSubsystem m [Meeting] + UpdateMeeting :: + Local UserId -> + Qualified MeetingId -> + UpdateMeeting -> + MeetingsSubsystem m (Maybe Meeting) + DeleteMeeting :: + Local UserId -> + Qualified MeetingId -> + MeetingsSubsystem m Bool + AddInvitedEmails :: + Local UserId -> + Qualified MeetingId -> + [EmailAddress] -> + MeetingsSubsystem m Bool + RemoveInvitedEmails :: + Local UserId -> + Qualified MeetingId -> + [EmailAddress] -> + MeetingsSubsystem m Bool + -- Cleanup operation + CleanupOldMeetings :: + UTCTime -> + Int -> + MeetingsSubsystem m Int64 + +makeSem ''MeetingsSubsystem diff --git a/libs/wire-subsystems/src/Wire/MeetingsSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/MeetingsSubsystem/Interpreter.hs new file mode 100644 index 0000000000..c95ecf2d5c --- /dev/null +++ b/libs/wire-subsystems/src/Wire/MeetingsSubsystem/Interpreter.hs @@ -0,0 +1,318 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2025 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.MeetingsSubsystem.Interpreter where + +import Data.Id +import Data.Qualified +import Data.Set qualified as Set +import Data.Time.Clock (UTCTime) +import Data.UUID.V4 qualified as UUIDV4 +import Imports +import Polysemy +import Wire.API.Conversation hiding (Member) +import Wire.API.Conversation.CellsState (CellsState (CellsDisabled)) +import Wire.API.Conversation.Role (roleNameWireAdmin) +import Wire.API.Meeting +import Wire.API.User (BaseProtocolTag (BaseProtocolMLSTag)) +import Wire.API.User.Identity (EmailAddress) +import Wire.ConversationStore qualified as ConvStore +import Wire.MeetingsStore qualified as Store +import Wire.MeetingsSubsystem +import Wire.StoredConversation +import Wire.UserList + +interpretMeetingsSubsystem :: + ( Member Store.MeetingsStore r, + Member ConvStore.ConversationStore r, + Member (Embed IO) r + ) => + InterpreterFor MeetingsSubsystem r +interpretMeetingsSubsystem = interpret $ \case + CreateMeeting zUser newMeeting trial -> + createMeetingImpl zUser newMeeting trial + GetMeeting zUser meetingId -> + getMeetingImpl zUser meetingId + ListMeetings zUser -> + listMeetingsImpl zUser + Wire.MeetingsSubsystem.UpdateMeeting zUser meetingId update -> + updateMeetingImpl zUser meetingId update + DeleteMeeting zUser meetingId -> + deleteMeetingImpl zUser meetingId + AddInvitedEmails zUser meetingId emails -> + addInvitedEmailsImpl zUser meetingId emails + RemoveInvitedEmails zUser meetingId emails -> + removeInvitedEmailsImpl zUser meetingId emails + CleanupOldMeetings cutoffTime batchSize -> + cleanupOldMeetingsImpl cutoffTime batchSize + +createMeetingImpl :: + ( Member Store.MeetingsStore r, + Member ConvStore.ConversationStore r, + Member (Embed IO) r + ) => + Local UserId -> + NewMeeting -> + Bool -> + Sem r (Meeting, StoredConversation) +createMeetingImpl zUser newMeeting trial = do + -- Generate meeting ID + meetingId <- liftIO $ MeetingId <$> UUIDV4.nextRandom + let qMeetingId = tUntagged (qualifyAs zUser meetingId) + + -- Generate new conversation ID + convId <- liftIO $ randomId + let lConvId = qualifyAs zUser convId + + -- Create conversation metadata for a meeting + let metadata = + ConversationMetadata + { cnvmType = RegularConv, + cnvmCreator = Just (tUnqualified zUser), + cnvmAccess = [], + cnvmAccessRoles = Set.empty, + cnvmName = Just newMeeting.title, + cnvmTeam = Nothing, + cnvmMessageTimer = Nothing, + cnvmReceiptMode = Nothing, + cnvmGroupConvType = Just MeetingConversation, + cnvmChannelAddPermission = Nothing, + cnvmCellsState = CellsDisabled, + cnvmParent = Nothing + } + + -- Create conversation with the meeting creator as the only member (admin role) + let newConv = + NewConversation + { metadata = metadata, + users = UserList [(tUnqualified zUser, roleNameWireAdmin)] [], + protocol = BaseProtocolMLSTag, + groupId = Nothing + } + + -- Store the conversation + storedConv <- ConvStore.upsertConversation lConvId newConv + let qConvId = tUntagged (qualifyAs zUser storedConv.id_) + + -- Store meeting (trial status is provided by caller) + Store.createMeeting + qMeetingId + (tUntagged zUser) + newMeeting.title + newMeeting.startDate + newMeeting.endDate + newMeeting.recurrence + qConvId + newMeeting.invitedEmails + trial + + -- Return created meeting + pure + ( Meeting + { id = qMeetingId, + title = newMeeting.title, + creator = tUntagged zUser, + startDate = newMeeting.startDate, + endDate = newMeeting.endDate, + recurrence = newMeeting.recurrence, + conversationId = qConvId, + invitedEmails = newMeeting.invitedEmails, + trial = trial + }, + storedConv + ) + +getMeetingImpl :: + ( Member Store.MeetingsStore r, + Member ConvStore.ConversationStore r + ) => + Local UserId -> + Qualified MeetingId -> + Sem r (Maybe Meeting) +getMeetingImpl zUser meetingId = do + -- Get meeting from store + maybeMeeting <- Store.getMeeting meetingId + + case maybeMeeting of + Nothing -> pure Nothing + Just meeting -> do + -- Check authorization: user must be creator OR member of the associated conversation + let isCreator = meeting.creator == tUntagged zUser + if isCreator + then pure (Just meeting) + else do + -- Check if user is a member of the conversation + let convId = qUnqualified meeting.conversationId + maybeMember <- ConvStore.getLocalMember convId (tUnqualified zUser) + case maybeMember of + Just _ -> pure (Just meeting) -- User is a member, authorized + Nothing -> pure Nothing -- User is not a member, not authorized + +listMeetingsImpl :: + ( Member Store.MeetingsStore r, + Member ConvStore.ConversationStore r + ) => + Local UserId -> + Sem r [Meeting] +listMeetingsImpl zUser = do + -- List all meetings created by the user + createdMeetings <- Store.listMeetingsByUser (tUnqualified zUser) + + -- Filter meetings to include only those where user is authorized + -- (creator or conversation member) + filterM (isAuthorized zUser) createdMeetings + where + isAuthorized :: (Member ConvStore.ConversationStore r) => Local UserId -> Meeting -> Sem r Bool + isAuthorized lUser meeting = do + -- User is authorized if they are the creator + let isCreator = meeting.creator == tUntagged lUser + if isCreator + then pure True + else do + -- Or if they are a member of the associated conversation + let convId = qUnqualified meeting.conversationId + maybeMember <- ConvStore.getLocalMember convId (tUnqualified lUser) + pure $ isJust maybeMember + +updateMeetingImpl :: + (Member Store.MeetingsStore r) => + Local UserId -> + Qualified MeetingId -> + UpdateMeeting -> + Sem r (Maybe Meeting) +updateMeetingImpl zUser meetingId update = do + -- Get existing meeting + maybeMeeting <- Store.getMeeting meetingId + case maybeMeeting of + Nothing -> pure Nothing + Just meeting -> + -- Check authorization (only creator can update) + if meeting.creator /= tUntagged zUser + then pure Nothing + else + -- Update meeting + Store.updateMeeting + meetingId + update.title + update.startDate + update.endDate + update.recurrence + +deleteMeetingImpl :: + ( Member Store.MeetingsStore r, + Member ConvStore.ConversationStore r + ) => + Local UserId -> + Qualified MeetingId -> + Sem r Bool +deleteMeetingImpl zUser meetingId = do + -- Get existing meeting + maybeMeeting <- Store.getMeeting meetingId + case maybeMeeting of + Nothing -> pure False + Just meeting -> + -- Check authorization (only creator can delete) + if meeting.creator /= tUntagged zUser + then pure False + else do + -- Delete meeting + Store.deleteMeeting meetingId + + -- Delete associated conversation if it's a meeting conversation + let convId = qUnqualified meeting.conversationId + maybeConv <- ConvStore.getConversation convId + case maybeConv of + Just conv + | conv.metadata.cnvmGroupConvType == Just MeetingConversation -> + ConvStore.deleteConversation convId + _ -> pure () + + pure True + +addInvitedEmailsImpl :: + (Member Store.MeetingsStore r) => + Local UserId -> + Qualified MeetingId -> + [EmailAddress] -> + Sem r Bool +addInvitedEmailsImpl zUser meetingId emails = do + -- Get existing meeting + maybeMeeting <- Store.getMeeting meetingId + case maybeMeeting of + Nothing -> pure False + Just meeting -> + -- Check authorization (only creator can add invitations) + if meeting.creator /= tUntagged zUser + then pure False + else do + -- Add invited email + Store.addInvitedEmails meetingId emails + pure True + +removeInvitedEmailsImpl :: + (Member Store.MeetingsStore r) => + Local UserId -> + Qualified MeetingId -> + [EmailAddress] -> + Sem r Bool +removeInvitedEmailsImpl zUser meetingId emails = do + -- Get existing meeting + maybeMeeting <- Store.getMeeting meetingId + case maybeMeeting of + Nothing -> pure False + Just meeting -> + -- Check authorization (only creator can remove invitations) + if meeting.creator /= tUntagged zUser + then pure False + else do + -- Remove invited email + Store.removeInvitedEmails meetingId emails + pure True + +cleanupOldMeetingsImpl :: + ( Member Store.MeetingsStore r, + Member ConvStore.ConversationStore r + ) => + UTCTime -> + Int -> + Sem r Int64 +cleanupOldMeetingsImpl cutoffTime batchSize = do + -- 1. Fetch old meetings + oldMeetings <- Store.getOldMeetings cutoffTime batchSize + + if null oldMeetings + then pure 0 + else do + -- 2. Extract meeting IDs and conversation IDs + let meetingIds = map (.id) oldMeetings + convIds = map (.conversationId) oldMeetings + + -- 3. Delete meetings from database + deletedCount <- Store.deleteMeetingBatch meetingIds + + -- 4. Delete associated conversations if they are meeting conversations + -- We need to check if conversation has GroupConvType = MeetingConversation + for_ convIds $ \qConvId -> do + let convId = qUnqualified qConvId + maybeConv <- ConvStore.getConversation convId + case maybeConv of + Just conv + | conv.metadata.cnvmGroupConvType == Just MeetingConversation -> + ConvStore.deleteConversation convId + _ -> pure () + + pure deletedCount diff --git a/libs/wire-subsystems/wire-subsystems.cabal b/libs/wire-subsystems/wire-subsystems.cabal index f8ea7fdff6..afcd81561d 100644 --- a/libs/wire-subsystems/wire-subsystems.cabal +++ b/libs/wire-subsystems/wire-subsystems.cabal @@ -272,6 +272,10 @@ library Wire.LegalHoldStore.Cassandra.Queries Wire.LegalHoldStore.Env Wire.ListItems + Wire.MeetingsStore + Wire.MeetingsStore.Postgres + Wire.MeetingsSubsystem + Wire.MeetingsSubsystem.Interpreter Wire.NotificationSubsystem Wire.NotificationSubsystem.Interpreter Wire.PaginationState diff --git a/postgres-schema.sql b/postgres-schema.sql index 378195989b..ce478aab3d 100644 --- a/postgres-schema.sql +++ b/postgres-schema.sql @@ -162,6 +162,29 @@ CREATE TABLE public.local_conversation_remote_member ( ALTER TABLE public.local_conversation_remote_member OWNER TO "wire-server"; +-- +-- Name: meetings; Type: TABLE; Schema: public; Owner: wire-server +-- + +CREATE TABLE public.meetings ( + id uuid NOT NULL, + domain text NOT NULL, + title text NOT NULL, + creator uuid NOT NULL, + start_date timestamp with time zone NOT NULL, + end_date timestamp with time zone NOT NULL, + schedule text, + conversation_id uuid NOT NULL, + conversation_domain text NOT NULL, + invited_emails text[] DEFAULT '{}'::text[], + trial boolean DEFAULT false, + created_at timestamp with time zone DEFAULT now(), + updated_at timestamp with time zone DEFAULT now() +); + + +ALTER TABLE public.meetings OWNER TO "wire-server"; + -- -- Name: mls_group_member_client; Type: TABLE; Schema: public; Owner: wire-server -- @@ -314,6 +337,14 @@ ALTER TABLE ONLY public.conversation ADD CONSTRAINT conversation_pkey PRIMARY KEY (id); +-- +-- Name: meetings meetings_pkey; Type: CONSTRAINT; Schema: public; Owner: wire-server +-- + +ALTER TABLE ONLY public.meetings + ADD CONSTRAINT meetings_pkey PRIMARY KEY (domain, id); + + -- -- Name: local_conversation_remote_member local_conversation_remote_member_pkey; Type: CONSTRAINT; Schema: public; Owner: wire-server -- @@ -413,6 +444,34 @@ CREATE INDEX conversation_team_group_type_lower_name_id_idx ON public.conversati CREATE INDEX conversation_team_idx ON public.conversation USING btree (team); +-- +-- Name: idx_meetings_conversation; Type: INDEX; Schema: public; Owner: wire-server +-- + +CREATE INDEX idx_meetings_conversation ON public.meetings USING btree (conversation_id, conversation_domain); + + +-- +-- Name: idx_meetings_creator; Type: INDEX; Schema: public; Owner: wire-server +-- + +CREATE INDEX idx_meetings_creator ON public.meetings USING btree (creator); + + +-- +-- Name: idx_meetings_end_date; Type: INDEX; Schema: public; Owner: wire-server +-- + +CREATE INDEX idx_meetings_end_date ON public.meetings USING btree (end_date); + + +-- +-- Name: idx_meetings_start_date; Type: INDEX; Schema: public; Owner: wire-server +-- + +CREATE INDEX idx_meetings_start_date ON public.meetings USING btree (start_date); + + -- -- Name: user_group_member_user_id_idx; Type: INDEX; Schema: public; Owner: wire-server -- diff --git a/services/background-worker/background-worker.cabal b/services/background-worker/background-worker.cabal index 891e864d63..6197716c94 100644 --- a/services/background-worker/background-worker.cabal +++ b/services/background-worker/background-worker.cabal @@ -21,6 +21,7 @@ library Wire.BackgroundWorker.Options Wire.BackgroundWorker.Util Wire.DeadUserNotificationWatcher + Wire.MeetingsCleanupWorker Wire.MigrateConversations hs-source-dirs: src @@ -57,6 +58,7 @@ library , servant-client , servant-server , text + , time , tinylog , transformers , transformers-base diff --git a/services/background-worker/background-worker.integration.yaml b/services/background-worker/background-worker.integration.yaml index 4ee7abbe10..7f10b97c28 100644 --- a/services/background-worker/background-worker.integration.yaml +++ b/services/background-worker/background-worker.integration.yaml @@ -75,5 +75,11 @@ backgroundJobs: jobTimeout: 5s maxAttempts: 3 +# Meetings cleanup configuration for integration +meetingsCleanup: + cleanOlderThanHours: 24 # Clean meetings older than 24 hours (for testing) + batchSize: 100 + cleanFrequencySeconds: 3600 # Run every hour + postgresMigration: conversation: postgresql diff --git a/services/background-worker/default.nix b/services/background-worker/default.nix index 011bc91bea..bf38b5f423 100644 --- a/services/background-worker/default.nix +++ b/services/background-worker/default.nix @@ -39,6 +39,7 @@ , servant-client-core , servant-server , text +, time , tinylog , transformers , transformers-base @@ -83,6 +84,7 @@ mkDerivation { servant-client servant-server text + time tinylog transformers transformers-base diff --git a/services/background-worker/src/Wire/BackgroundWorker.hs b/services/background-worker/src/Wire/BackgroundWorker.hs index c30c1d809a..83b3ba6b4b 100644 --- a/services/background-worker/src/Wire/BackgroundWorker.hs +++ b/services/background-worker/src/Wire/BackgroundWorker.hs @@ -34,6 +34,7 @@ import Wire.BackgroundWorker.Health qualified as Health import Wire.BackgroundWorker.Jobs.Consumer qualified as Jobs import Wire.BackgroundWorker.Options import Wire.DeadUserNotificationWatcher qualified as DeadUserNotificationWatcher +import Wire.MeetingsCleanupWorker qualified as MeetingsCleanupWorker import Wire.MigrateConversations qualified as MigrateConversations run :: Opts -> IO () @@ -59,13 +60,18 @@ run opts = do runAppT env $ withNamedLogger "background-job-consumer" $ Jobs.startWorker amqpEP + cleanupMeetings <- + runAppT env $ + withNamedLogger "meetings-cleanup" $ + MeetingsCleanupWorker.startWorker opts.meetingsCleanup let cleanup = void . runConcurrently $ - (,,,) + (,,,,) <$> Concurrently cleanupDeadUserNotifWatcher <*> Concurrently cleanupBackendNotifPusher <*> Concurrently cleanupConvMigration <*> Concurrently cleanupJobs + <*> Concurrently cleanupMeetings let server = defaultServer (T.unpack opts.backgroundWorker.host) opts.backgroundWorker.port env.logger let settings = newSettings server diff --git a/services/background-worker/src/Wire/BackgroundWorker/Options.hs b/services/background-worker/src/Wire/BackgroundWorker/Options.hs index 48cc531b58..56ad1c2729 100644 --- a/services/background-worker/src/Wire/BackgroundWorker/Options.hs +++ b/services/background-worker/src/Wire/BackgroundWorker/Options.hs @@ -53,6 +53,7 @@ data Opts = Opts migrateConversations :: !Bool, migrateConversationsOptions :: !MigrationOptions, backgroundJobs :: BackgroundJobsConfig, + meetingsCleanup :: MeetingsCleanupConfig, federationDomain :: Domain } deriving (Show, Generic) @@ -95,3 +96,14 @@ data BackgroundJobsConfig = BackgroundJobsConfig } deriving (Show, Generic) deriving (FromJSON) via Generically BackgroundJobsConfig + +data MeetingsCleanupConfig = MeetingsCleanupConfig + { -- | Delete meetings older than this many hours + cleanOlderThanHours :: Int, + -- | Maximum number of meetings to delete per batch + batchSize :: Int, + -- | Frequency in seconds to run the cleanup job + cleanFrequencySeconds :: Int + } + deriving (Show, Generic) + deriving (FromJSON) via Generically MeetingsCleanupConfig diff --git a/services/background-worker/src/Wire/MeetingsCleanupWorker.hs b/services/background-worker/src/Wire/MeetingsCleanupWorker.hs new file mode 100644 index 0000000000..879af23385 --- /dev/null +++ b/services/background-worker/src/Wire/MeetingsCleanupWorker.hs @@ -0,0 +1,139 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2025 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.MeetingsCleanupWorker + ( startWorker, + cleanupOldMeetings, + CleanupConfig (..), + ) +where + +import Data.Bifunctor (first) +import Data.Time.Clock +import Hasql.Pool (UsageError) +import Imports +import Polysemy +import Polysemy.Error (runError) +import Polysemy.Input (runInputConst) +import System.Logger qualified as Log +import UnliftIO (async) +import Wire.BackgroundWorker.Env (AppT, Env (..)) +import Wire.BackgroundWorker.Options (MeetingsCleanupConfig (..)) +import Wire.BackgroundWorker.Util (CleanupAction) +import Wire.ConversationStore.Postgres (interpretConversationStoreToPostgres) +import Wire.MeetingsStore.Postgres (interpretMeetingsStoreToPostgres) +import Wire.MeetingsSubsystem qualified as Meetings +import Wire.MeetingsSubsystem.Interpreter (interpretMeetingsSubsystem) + +data CleanupConfig = CleanupConfig + { retentionHours :: Int, + batchSize :: Int + } + deriving (Show, Eq) + +-- | Start the meetings cleanup worker thread +-- +-- This worker runs periodically to clean up old meetings based on the configuration. +-- It sleeps for the configured frequency and then runs the cleanup operation. +startWorker :: + MeetingsCleanupConfig -> + AppT IO CleanupAction +startWorker config = do + env <- ask + -- Start the worker loop in a separate thread + void . async $ workerLoop env config + -- Return a no-op cleanup action (worker will be killed when the process exits) + pure $ pure () + +-- | Worker loop that runs periodically +workerLoop :: Env -> MeetingsCleanupConfig -> AppT IO () +workerLoop env config = forever $ do + -- Sleep for the configured frequency (convert seconds to microseconds) + liftIO $ threadDelay (config.cleanFrequencySeconds * 1_000_000) + + Log.info env.logger $ + Log.msg (Log.val "Starting scheduled meetings cleanup") + . Log.field "clean_older_than_hours" config.cleanOlderThanHours + . Log.field "batch_size" config.batchSize + . Log.field "frequency_seconds" config.cleanFrequencySeconds + + -- Run the cleanup + cleanupOldMeetings (configFromOptions config) + +-- | Convert MeetingsCleanupConfig to CleanupConfig +configFromOptions :: MeetingsCleanupConfig -> CleanupConfig +configFromOptions cfg = + CleanupConfig + { retentionHours = cfg.cleanOlderThanHours, + batchSize = cfg.batchSize + } + +-- | Main cleanup function that orchestrates the cleanup process +cleanupOldMeetings :: CleanupConfig -> AppT IO () +cleanupOldMeetings config = do + env <- ask + now <- liftIO getCurrentTime + let cutoffTime = addUTCTime (negate $ fromIntegral config.retentionHours * 3600) now + + Log.info env.logger $ + Log.msg (Log.val "Starting cleanup of old meetings") + . Log.field "cutoff_time" (show cutoffTime) + . Log.field "retention_hours" config.retentionHours + . Log.field "batch_size" config.batchSize + + -- Loop until no more meetings are deleted + totalDeleted <- cleanupLoop env cutoffTime config.batchSize 0 + + Log.info env.logger $ + Log.msg (Log.val "Completed cleanup of old meetings") + . Log.field "total_deleted" totalDeleted + +cleanupLoop :: Env -> UTCTime -> Int -> Int64 -> AppT IO Int64 +cleanupLoop env cutoffTime batchSize totalSoFar = do + -- Run the subsystem to handle cleanup logic + result <- liftIO $ runMeetingsCleanup env cutoffTime batchSize + + case result of + Left err -> do + Log.err env.logger $ + Log.msg (Log.val "Failed to cleanup old meetings batch") + . Log.field "error" (show err) + . Log.field "total_deleted_so_far" totalSoFar + pure totalSoFar + Right deletedCount -> do + let newTotal = totalSoFar + deletedCount + Log.info env.logger $ + Log.msg (Log.val "Cleaned up meetings batch") + . Log.field "batch_deleted" deletedCount + . Log.field "total_deleted" newTotal + -- Continue if we deleted a full batch (meaning there might be more) + if deletedCount >= fromIntegral batchSize + then cleanupLoop env cutoffTime batchSize newTotal + else pure newTotal + +-- Run the meetings cleanup using the subsystem +runMeetingsCleanup :: Env -> UTCTime -> Int -> IO (Either String Int64) +runMeetingsCleanup env cutoffTime batchSize = + fmap (first show) + . runM + . runError @UsageError + . runInputConst env.hasqlPool + . interpretMeetingsStoreToPostgres + . runInputConst env.hasqlPool + . interpretConversationStoreToPostgres + . interpretMeetingsSubsystem + $ Meetings.cleanupOldMeetings cutoffTime batchSize diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index 8f8d45f27d..e7e1df4cff 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -89,6 +89,7 @@ library Galley.API.LegalHold.Get Galley.API.LegalHold.Team Galley.API.Mapping + Galley.API.Meetings Galley.API.Message Galley.API.MLS Galley.API.MLS.CheckClients @@ -119,6 +120,7 @@ library Galley.API.Public.CustomBackend Galley.API.Public.Feature Galley.API.Public.LegalHold + Galley.API.Public.Meetings Galley.API.Public.Messaging Galley.API.Public.MLS Galley.API.Public.Servant @@ -363,6 +365,7 @@ executable galley-integration API.CustomBackend API.Federation API.Federation.Util + API.Meetings API.MessageTimer API.MLS API.MLS.Mocks diff --git a/services/galley/postgresql-migrations/001_meetings.sql b/services/galley/postgresql-migrations/001_meetings.sql new file mode 100644 index 0000000000..740661b530 --- /dev/null +++ b/services/galley/postgresql-migrations/001_meetings.sql @@ -0,0 +1,102 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2025 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 . + +-- Migration: Add meetings table to PostgreSQL +-- Description: Creates the meetings table with all required fields, indices, and constraints + +CREATE TABLE IF NOT EXISTS meetings ( + -- Meeting identification + id uuid NOT NULL, + domain text NOT NULL, + + -- Meeting metadata + title text NOT NULL, + creator uuid NOT NULL, + creator_domain text NOT NULL, + + -- Scheduling information + start_date timestamptz NOT NULL, + end_date timestamptz NOT NULL, + recurrence jsonb, + + -- Associated conversation + conversation_id uuid NOT NULL, + conversation_domain text NOT NULL, + + -- Invitations + invited_emails text[] NOT NULL DEFAULT '{}', + + -- Feature flags + trial boolean NOT NULL DEFAULT false, + + -- Timestamps + created_at timestamptz NOT NULL DEFAULT NOW(), + + -- Primary key + PRIMARY KEY (domain, id) +); + +-- Indices for performance + +-- Index for looking up meetings by creator (user) +CREATE INDEX IF NOT EXISTS idx_meetings_creator + ON meetings(creator); + +-- Index for looking up meetings by conversation +CREATE INDEX IF NOT EXISTS idx_meetings_conversation + ON meetings(conversation_domain, conversation_id); + +-- Index for cleanup queries (finding old meetings) +CREATE INDEX IF NOT EXISTS idx_meetings_end_date + ON meetings(end_date); + +-- Index for querying meetings within a time range +CREATE INDEX IF NOT EXISTS idx_meetings_start_date + ON meetings(start_date); + +-- Constraints + +-- Ensure end_date is after start_date +ALTER TABLE meetings + ADD CONSTRAINT meetings_valid_date_range + CHECK (end_date > start_date); + +-- Ensure title is not empty +ALTER TABLE meetings + ADD CONSTRAINT meetings_title_not_empty + CHECK (length(trim(title)) > 0); + +-- Ensure title is not too long (reasonable limit) +ALTER TABLE meetings + ADD CONSTRAINT meetings_title_length + CHECK (length(title) <= 256); + +-- Comments for documentation +COMMENT ON TABLE meetings IS 'Scheduled meetings with email invitations'; +COMMENT ON COLUMN meetings.id IS 'Unique meeting identifier (UUID)'; +COMMENT ON COLUMN meetings.domain IS 'Federation domain for the meeting'; +COMMENT ON COLUMN meetings.title IS 'Meeting title/subject'; +COMMENT ON COLUMN meetings.creator IS 'User ID who created the meeting'; +COMMENT ON COLUMN meetings.creator_domain IS 'Domain of the user who created the meeting'; +COMMENT ON COLUMN meetings.start_date IS 'Meeting start time'; +COMMENT ON COLUMN meetings.end_date IS 'Meeting end time'; +COMMENT ON COLUMN meetings.recurrence IS 'Optional recurring schedule information (JSON)'; +COMMENT ON COLUMN meetings.conversation_id IS 'Associated conversation ID'; +COMMENT ON COLUMN meetings.conversation_domain IS 'Domain of the associated conversation'; +COMMENT ON COLUMN meetings.invited_emails IS 'Array of email addresses invited to the meeting'; +COMMENT ON COLUMN meetings.trial IS 'Whether this meeting is created under a trial account'; +COMMENT ON COLUMN meetings.created_at IS 'Timestamp when the meeting was created'; diff --git a/services/galley/src/Galley/API/Create.hs b/services/galley/src/Galley/API/Create.hs index 6de6c71e7c..bbcfb8785b 100644 --- a/services/galley/src/Galley/API/Create.hs +++ b/services/galley/src/Galley/API/Create.hs @@ -48,10 +48,10 @@ import Galley.API.MLS import Galley.API.Mapping import Galley.API.One2One import Galley.API.Teams.Features.Get (getFeatureForTeam) -import Galley.API.Util +import Galley.API.Util hiding (notifyCreatedConversation) import Galley.App (Env) import Galley.Effects -import Galley.Options (Opts) +import Galley.Options import Galley.Types.Teams (notTeamMember) import Galley.Validation import Imports hiding ((\\)) @@ -429,6 +429,8 @@ checkCreateConvPermissions lusr newConv (Just tinfo) allUsers = do -- so we don't allow an external partner to create an MLS group conversation at all when (length allUsers > 1 || newConv.newConvProtocol == BaseProtocolMLSTag) $ do void $ permissionCheck AddRemoveConvMember teamAssociation + MeetingConversation -> + throwS @OperationDenied convLocalMemberships <- mapM (flip TeamSubsystem.internalGetTeamMember convTeam) (ulLocals allUsers) ensureAccessRole (accessRoles newConv) (zip (ulLocals allUsers) convLocalMemberships) @@ -750,19 +752,7 @@ createConnectConversation lusr conn j = do where create lcnv nc = do c <- E.upsertConversation lcnv nc - now <- Now.get - let e = Event (tUntagged lcnv) Nothing (EventFromUser (tUntagged lusr)) now Nothing (EdConnect j) - notifyCreatedConversation lusr conn c def - pushNotifications - [ def - { origin = Just (tUnqualified lusr), - json = toJSONObject e, - recipients = map localMemberToRecipient c.localMembers, - isCellsEvent = shouldPushToCells c.metadata e, - route = PushV2.RouteDirect, - conn - } - ] + notifyConversationCreated lusr conn j lcnv c conversationCreated lusr c update n conv = do let mems = conv.localMembers @@ -789,24 +779,12 @@ createConnectConversation lusr conn j = do else pure conv'' connect n conv | Data.convType conv == ConnectConv = do - let lcnv = qualifyAs lusr conv.id_ n' <- case n of Just x -> do E.setConversationName conv.id_ x pure . Just $ fromRange x Nothing -> pure $ Data.convName conv - t <- Now.get - let e = Event (tUntagged lcnv) Nothing (EventFromUser (tUntagged lusr)) t Nothing (EdConnect j) - pushNotifications - [ def - { origin = Just (tUnqualified lusr), - json = toJSONObject e, - recipients = map localMemberToRecipient conv.localMembers, - isCellsEvent = shouldPushToCells conv.metadata e, - route = PushV2.RouteDirect, - conn - } - ] + notifyConversationUpdated lusr conn j conv pure $ Data.convSetName n' conv | otherwise = pure conv diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index 5e738062b2..f8511e1993 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -292,6 +292,7 @@ allFeaturesAPI = <@> featureAPI1Get <@> featureAPI1Full <@> featureAPI1Full + <@> featureAPI1Full featureAPI :: API IFeatureAPI GalleyEffects featureAPI = @@ -315,6 +316,7 @@ featureAPI = <@> mkNamedAPI @'("ilock", AppsConfig) (updateLockStatus @AppsConfig) <@> mkNamedAPI @'("ilock", SimplifiedUserConnectionRequestQRCodeConfig) (updateLockStatus @SimplifiedUserConnectionRequestQRCodeConfig) <@> mkNamedAPI @'("ilock", StealthUsersConfig) (updateLockStatus @StealthUsersConfig) + <@> mkNamedAPI @'("ilock", PayingTeamConfig) (updateLockStatus @PayingTeamConfig) -- all features <@> mkNamedAPI @"feature-configs-internal" (maybe getAllTeamFeaturesForServer getAllTeamFeaturesForUser) diff --git a/services/galley/src/Galley/API/Meetings.hs b/services/galley/src/Galley/API/Meetings.hs new file mode 100644 index 0000000000..b974d84e57 --- /dev/null +++ b/services/galley/src/Galley/API/Meetings.hs @@ -0,0 +1,185 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2025 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.API.Meetings + ( createMeeting, + getMeeting, + listMeetings, + updateMeeting, + deleteMeeting, + addMeetingInvitation, + removeMeetingInvitation, + ) +where + +import Data.Domain (Domain) +import Data.Id +import Data.Qualified +import Galley.API.Error +import Galley.API.Teams.Features.Get (getFeatureForTeam) +import Galley.API.Util +import Galley.Effects +import Galley.Options (Opts) +import Imports +import Polysemy +import Polysemy.Error +import Polysemy.Input +import Polysemy.TinyLog qualified as P +import Wire.API.Conversation (JoinType (InternalAdd)) +import Wire.API.Error +import Wire.API.Error.Galley +import Wire.API.Federation.Client (FederatorClient) +import Wire.API.Federation.Error +import Wire.API.Meeting +import Wire.API.Team.Feature (FeatureStatus (..), LockableFeature (..), PayingTeamConfig) +import Wire.FederationAPIAccess () +import Wire.MeetingsSubsystem qualified as Meetings +import Wire.NotificationSubsystem +import Wire.Sem.Now (Now) +import Wire.TeamStore qualified as TeamStore + +createMeeting :: + ( Member Meetings.MeetingsSubsystem r, + Member (ErrorS 'InvalidOperation) r, + Member (ErrorS 'NotATeamMember) r, + Member BackendNotificationQueueAccess r, + Member ConversationStore r, + Member (Error FederationError) r, + Member (Error InternalError) r, + Member (Error UnreachableBackends) r, + Member (FederationAPIAccess FederatorClient) r, + Member NotificationSubsystem r, + Member Now r, + Member P.TinyLog r, + Member TeamStore r, + Member TeamFeatureStore r, + Member (Input Opts) r + ) => + Local UserId -> + NewMeeting -> + Sem r Meeting +createMeeting lUser newMeeting = do + -- Validate that endDate > startDate + when (newMeeting.endDate <= newMeeting.startDate) $ + throwS @'InvalidOperation + + -- Determine trial status based on team membership and paying team feature + trial <- do + maybeTeamId <- TeamStore.getOneUserTeam (tUnqualified lUser) + case maybeTeamId of + Nothing -> pure True -- Personal users are trial + Just teamId -> do + -- Verify user is a team member (not just a collaborator) + maybeMember <- TeamStore.getTeamMember teamId (tUnqualified lUser) + case maybeMember of + Nothing -> throwS @'NotATeamMember -- User not a member + Just _member -> do + -- Check paying team feature status + payingFeature <- getFeatureForTeam @PayingTeamConfig teamId + pure $ case payingFeature of + LockableFeature {status = FeatureStatusEnabled} -> False -- paying team, not trial + _ -> True -- non-paying team or disabled, is trial + (meeting, conversation) <- Meetings.createMeeting lUser newMeeting trial + notifyCreatedConversation lUser Nothing conversation InternalAdd + pure meeting + +getMeeting :: + ( Member Meetings.MeetingsSubsystem r, + Member (ErrorS 'MeetingNotFound) r + ) => + Local UserId -> + Domain -> + MeetingId -> + Sem r Meeting +getMeeting zUser domain meetingId = do + let qMeetingId = Qualified meetingId domain + maybeMeeting <- Meetings.getMeeting zUser qMeetingId + case maybeMeeting of + Nothing -> throwS @'MeetingNotFound + Just meeting -> pure meeting + +listMeetings :: + ( Member Meetings.MeetingsSubsystem r + ) => + Local UserId -> + Sem r [Meeting] +listMeetings = Meetings.listMeetings + +updateMeeting :: + ( Member Meetings.MeetingsSubsystem r, + Member (ErrorS 'MeetingNotFound) r, + Member (ErrorS 'InvalidOperation) r + ) => + Local UserId -> + Domain -> + MeetingId -> + UpdateMeeting -> + Sem r Meeting +updateMeeting zUser domain meetingId update = do + -- Validate that at least one field is being updated + when (isNothing update.title && isNothing update.startDate && isNothing update.endDate && isNothing update.recurrence) $ + throwS @'InvalidOperation + -- Validate dates if both are provided + case (update.startDate, update.endDate) of + (Just start, Just end) -> when (end <= start) $ throwS @'InvalidOperation + _ -> pure () + let qMeetingId = Qualified meetingId domain + maybeMeeting <- Meetings.updateMeeting zUser qMeetingId update + case maybeMeeting of + Nothing -> throwS @'MeetingNotFound + Just meeting -> pure meeting + +deleteMeeting :: + ( Member Meetings.MeetingsSubsystem r, + Member (ErrorS 'MeetingNotFound) r + ) => + Local UserId -> + Domain -> + MeetingId -> + Sem r () +deleteMeeting zUser domain meetingId = do + let qMeetingId = Qualified meetingId domain + success <- Meetings.deleteMeeting zUser qMeetingId + unless success $ throwS @'MeetingNotFound + +addMeetingInvitation :: + ( Member Meetings.MeetingsSubsystem r, + Member (ErrorS 'MeetingNotFound) r + ) => + Local UserId -> + Domain -> + MeetingId -> + MeetingEmailsInvitation -> + Sem r () +addMeetingInvitation zUser domain meetingId (MeetingEmailsInvitation emails) = do + let qMeetingId = Qualified meetingId domain + success <- Meetings.addInvitedEmails zUser qMeetingId emails + unless success $ throwS @'MeetingNotFound + +removeMeetingInvitation :: + ( Member Meetings.MeetingsSubsystem r, + Member (ErrorS 'MeetingNotFound) r + ) => + Local UserId -> + Domain -> + MeetingId -> + MeetingEmailsInvitation -> + Sem r () +removeMeetingInvitation zUser domain meetingId (MeetingEmailsInvitation emails) = do + let qMeetingId = Qualified meetingId domain + success <- Meetings.removeInvitedEmails zUser qMeetingId emails + unless success $ throwS @'MeetingNotFound diff --git a/services/galley/src/Galley/API/Public/Feature.hs b/services/galley/src/Galley/API/Public/Feature.hs index ccfd15e38d..a7192fe39b 100644 --- a/services/galley/src/Galley/API/Public/Feature.hs +++ b/services/galley/src/Galley/API/Public/Feature.hs @@ -78,6 +78,7 @@ featureAPI = <@> mkNamedAPI @'("get", SimplifiedUserConnectionRequestQRCodeConfig) getFeature <@> mkNamedAPI @'("get", StealthUsersConfig) getFeature <@> mkNamedAPI @'("get", CellsInternalConfig) getFeature + <@> featureAPIGetPut deprecatedFeatureConfigAPI :: API DeprecatedFeatureAPI GalleyEffects deprecatedFeatureConfigAPI = diff --git a/services/galley/src/Galley/API/Public/Meetings.hs b/services/galley/src/Galley/API/Public/Meetings.hs new file mode 100644 index 0000000000..0914b15f27 --- /dev/null +++ b/services/galley/src/Galley/API/Public/Meetings.hs @@ -0,0 +1,33 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2025 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.API.Public.Meetings where + +import Galley.API.Meetings qualified as Meetings +import Galley.App +import Wire.API.Routes.API +import Wire.API.Routes.Public.Galley.Meetings + +meetingsAPI :: API MeetingsAPI GalleyEffects +meetingsAPI = + mkNamedAPI @"create-meeting" Meetings.createMeeting + <@> mkNamedAPI @"list-meetings" Meetings.listMeetings + <@> mkNamedAPI @"get-meeting" Meetings.getMeeting + <@> mkNamedAPI @"update-meeting" Meetings.updateMeeting + <@> mkNamedAPI @"delete-meeting" Meetings.deleteMeeting + <@> mkNamedAPI @"add-meeting-invitation" Meetings.addMeetingInvitation + <@> mkNamedAPI @"remove-meeting-invitation" Meetings.removeMeetingInvitation diff --git a/services/galley/src/Galley/API/Public/Servant.hs b/services/galley/src/Galley/API/Public/Servant.hs index ea777ec499..7db4f47181 100644 --- a/services/galley/src/Galley/API/Public/Servant.hs +++ b/services/galley/src/Galley/API/Public/Servant.hs @@ -23,6 +23,7 @@ import Galley.API.Public.CustomBackend import Galley.API.Public.Feature import Galley.API.Public.LegalHold import Galley.API.Public.MLS +import Galley.API.Public.Meetings import Galley.API.Public.Messaging import Galley.API.Public.Team import Galley.API.Public.TeamConversation @@ -41,6 +42,7 @@ servantSitemap = <@> teamAPI <@> featureAPI <@> mlsAPI + <@> meetingsAPI <@> customBackendAPI <@> legalHoldAPI <@> teamMemberAPI diff --git a/services/galley/src/Galley/API/Teams/Features.hs b/services/galley/src/Galley/API/Teams/Features.hs index 72da3558e0..dbc53ddcd5 100644 --- a/services/galley/src/Galley/API/Teams/Features.hs +++ b/services/galley/src/Galley/API/Teams/Features.hs @@ -485,3 +485,5 @@ instance SetFeatureConfig AppsConfig instance SetFeatureConfig SimplifiedUserConnectionRequestQRCodeConfig instance SetFeatureConfig StealthUsersConfig + +instance SetFeatureConfig PayingTeamConfig diff --git a/services/galley/src/Galley/API/Teams/Features/Get.hs b/services/galley/src/Galley/API/Teams/Features/Get.hs index ff817e0169..644de12fb0 100644 --- a/services/galley/src/Galley/API/Teams/Features/Get.hs +++ b/services/galley/src/Galley/API/Teams/Features/Get.hs @@ -428,6 +428,8 @@ instance GetFeatureConfig SimplifiedUserConnectionRequestQRCodeConfig instance GetFeatureConfig StealthUsersConfig +instance GetFeatureConfig PayingTeamConfig + -- | If second factor auth is enabled, make sure that end-points that don't support it, but -- should, are blocked completely. (This is a workaround until we have 2FA for those -- end-points as well.) diff --git a/services/galley/src/Galley/API/Util.hs b/services/galley/src/Galley/API/Util.hs index aa6a22995e..eb5019903b 100644 --- a/services/galley/src/Galley/API/Util.hs +++ b/services/galley/src/Galley/API/Util.hs @@ -47,6 +47,7 @@ import Galley.Effects import Galley.Effects.ClientStore import Galley.Effects.CodeStore import Galley.Env +import Galley.Options () import Galley.Types.Clients (Clients, fromUserClients) import Galley.Types.Conversations.Roles import Galley.Types.Teams @@ -90,6 +91,7 @@ import Wire.ConversationStore import Wire.ConversationSubsystem.Interpreter (ConversationSubsystemConfig (..)) import Wire.ExternalAccess import Wire.FederationAPIAccess +import Wire.FederationAPIAccess qualified as E import Wire.HashPassword (HashPassword) import Wire.HashPassword qualified as HashPassword import Wire.LegalHoldStore @@ -1187,3 +1189,109 @@ instance if err' == demote @e then throwS @e else rethrowErrors @effs @r err' + +---------------------------------------------------------------------------- +-- Notifications +notifyConversationCreated :: + ( Member BackendNotificationQueueAccess r, + Member ConversationStore r, + Member (Error FederationError) r, + Member (Error InternalError) r, + Member (Error UnreachableBackends) r, + Member (FederationAPIAccess FederatorClient) r, + Member NotificationSubsystem r, + Member Now r, + Member P.TinyLog r + ) => + Local UserId -> + Maybe ConnId -> + Connect -> + Local ConvId -> + StoredConversation -> + Sem r () +notifyConversationCreated lusr conn j lcnv c = do + now <- Now.get + let e = Event (tUntagged lcnv) Nothing (EventFromUser (tUntagged lusr)) now Nothing (EdConnect j) + notifyCreatedConversation lusr conn c def + pushNotifications + [ def + { origin = Just (tUnqualified lusr), + json = toJSONObject e, + recipients = map localMemberToRecipient c.localMembers, + isCellsEvent = shouldPushToCells c.metadata e, + route = PushV2.RouteDirect, + conn + } + ] + +notifyCreatedConversation :: + ( Member ConversationStore r, + Member (Error FederationError) r, + Member (Error InternalError) r, + Member (Error UnreachableBackends) r, + Member (FederationAPIAccess FederatorClient) r, + Member NotificationSubsystem r, + Member BackendNotificationQueueAccess r, + Member Now r, + Member P.TinyLog r + ) => + Local UserId -> + Maybe ConnId -> + StoredConversation -> + JoinType -> + Sem r () +notifyCreatedConversation lusr conn c joinType = do + now <- Now.get + -- Ask remote servers to store conversation membership and notify remote users + -- of being added to a conversation + registerRemoteConversationMemberships now lusr (qualifyAs lusr c) joinType + unless (null c.remoteMembers) $ + unlessM E.isFederationConfigured $ + throw FederationNotConfigured + + -- Notify local users + pushNotifications =<< mapM (toPush now) c.localMembers + where + route + | Data.convType c == RegularConv = PushV2.RouteAny + | otherwise = PushV2.RouteDirect + toPush t m = do + let remoteOthers = remoteMemberToOther <$> c.remoteMembers + localOthers = map (localMemberToOther (tDomain lusr)) $ c.localMembers + lconv = qualifyAs lusr c.id_ + c' <- conversationViewWithCachedOthers remoteOthers localOthers c (qualifyAs lusr m.id_) + let e = Event (tUntagged lconv) Nothing (EventFromUser (tUntagged lusr)) t Nothing (EdConversation c') + pure $ + def + { origin = Just (tUnqualified lusr), + json = toJSONObject e, + recipients = [localMemberToRecipient m], + -- on conversation creation we send the cells event separately to make sure it is sent exactly once + isCellsEvent = False, + route, + conn + } + +notifyConversationUpdated :: + ( Member NotificationSubsystem r, + Member Now r + ) => + Local UserId -> + Maybe ConnId -> + Connect -> + StoredConversation -> + Sem r () +notifyConversationUpdated lusr conn j conv = do + let lcnv = qualifyAs lusr conv.id_ + t <- Now.get + let e = Event (tUntagged lcnv) Nothing (EventFromUser (tUntagged lusr)) t Nothing (EdConnect j) + pushNotifications + [ def + { origin = Just (tUnqualified lusr), + json = toJSONObject e, + recipients = map localMemberToRecipient conv.localMembers, + isCellsEvent = shouldPushToCells conv.metadata e, + route = PushV2.RouteDirect, + conn + } + ] diff --git a/services/galley/src/Galley/App.hs b/services/galley/src/Galley/App.hs index 7808ea80ed..73c477ede5 100644 --- a/services/galley/src/Galley/App.hs +++ b/services/galley/src/Galley/App.hs @@ -119,6 +119,8 @@ import Wire.GundeckAPIAccess (runGundeckAPIAccess) import Wire.HashPassword.Interpreter import Wire.LegalHoldStore.Cassandra (interpretLegalHoldStoreToCassandra) import Wire.LegalHoldStore.Env (LegalHoldEnv (..)) +import Wire.MeetingsStore.Postgres (interpretMeetingsStoreToPostgres) +import Wire.MeetingsSubsystem.Interpreter import Wire.NotificationSubsystem.Interpreter (runNotificationSubsystemGundeck) import Wire.ParseException import Wire.ProposalStore.Cassandra @@ -340,6 +342,8 @@ evalGalley e = . runInputConst e . runInputConst (e ^. hasqlPool) . runInputConst (e ^. cstate) + . mapError toResponse -- ErrorS 'InvalidOperation + . mapError toResponse -- ErrorS 'MeetingNotFound . mapError toResponse . mapError toResponse . mapError rateLimitExceededToHttpError @@ -373,6 +377,7 @@ evalGalley e = . interpretProposalStoreToCassandra . interpretCodeStoreToCassandra . interpretClientStoreToCassandra + . interpretMeetingsStoreToPostgres . interpretTeamCollaboratorsStoreToPostgres . interpretFireAndForget . BackendNotificationQueueAccess.interpretBackendNotificationQueueAccess backendNotificationQueueAccessEnv @@ -385,6 +390,7 @@ evalGalley e = . interpretSparAPIAccessToRpc (e ^. options . spar) . interpretTeamSubsystem teamSubsystemConfig . interpretConversationSubsystem + . interpretMeetingsSubsystem . interpretTeamCollaboratorsSubsystem where lh = view (options . settings . featureFlags . to npProject) e diff --git a/services/galley/src/Galley/Effects.hs b/services/galley/src/Galley/Effects.hs index 4b20074f9a..f96a97bed9 100644 --- a/services/galley/src/Galley/Effects.hs +++ b/services/galley/src/Galley/Effects.hs @@ -92,6 +92,8 @@ import Wire.HashPassword import Wire.LegalHoldStore import Wire.LegalHoldStore.Env (LegalHoldEnv) import Wire.ListItems +import Wire.MeetingsStore (MeetingsStore) +import Wire.MeetingsSubsystem (MeetingsSubsystem) import Wire.NotificationSubsystem import Wire.ProposalStore import Wire.RateLimit @@ -111,6 +113,7 @@ import Wire.UserGroupStore -- All the possible high-level effects. type GalleyEffects1 = '[ TeamCollaboratorsSubsystem, + MeetingsSubsystem, ConversationSubsystem, TeamSubsystem, SparAPIAccess, @@ -123,6 +126,7 @@ type GalleyEffects1 = BackendNotificationQueueAccess, FireAndForget, TeamCollaboratorsStore, + MeetingsStore, ClientStore, CodeStore, ProposalStore, @@ -155,5 +159,7 @@ type GalleyEffects1 = Error DynError, Error RateLimitExceeded, ErrorS OperationDenied, - ErrorS 'NotATeamMember + ErrorS 'NotATeamMember, + ErrorS 'MeetingNotFound, + ErrorS 'InvalidOperation ] diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index e0f65f5d3a..ce0a4fd272 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -28,6 +28,7 @@ where import API.CustomBackend qualified as CustomBackend import API.Federation qualified as Federation import API.MLS qualified +import API.Meetings qualified as Meetings import API.MessageTimer qualified as MessageTimer import API.Roles qualified as Roles import API.SQS @@ -118,6 +119,7 @@ tests s = MessageTimer.tests s, Roles.tests s, CustomBackend.tests s, + Meetings.tests s, Federation.tests s, API.MLS.tests s ] diff --git a/services/galley/test/integration/API/Meetings.hs b/services/galley/test/integration/API/Meetings.hs new file mode 100644 index 0000000000..6141575db5 --- /dev/null +++ b/services/galley/test/integration/API/Meetings.hs @@ -0,0 +1,653 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2025 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 API.Meetings + ( tests, + ) +where + +import API.Util +import Bilge hiding (timeout) +import Bilge.Assert +import Data.Aeson +import Data.ByteString.Conversion (toByteString') +import Data.Id (randomId, toUUID) +import Data.Qualified (qDomain, qUnqualified) +import Data.Time.Clock +import Data.UUID qualified as UUID +import Imports +import Test.Tasty +import Test.Tasty.HUnit ((@?=)) +import TestHelpers +import TestSetup +import Wire.API.Meeting +import Wire.API.User.Identity (emailAddressText) + +-- Helper to convert MeetingId to ByteString for URL paths +meetingIdToBS :: MeetingId -> ByteString +meetingIdToBS = toByteString' . UUID.toText . unMeetingId + +tests :: IO TestSetup -> TestTree +tests s = + testGroup + "Meetings API" + [ test s "POST /meetings - create meeting" testMeetingCreate, + test s "GET /meetings - list meetings" testMeetingLists, + test s "GET /meetings/:domain/:id - get meeting" testMeetingGet, + test s "GET /meetings/:domain/:id - meeting not found (404)" testMeetingGetNotFound, + test s "PUT /meetings/:domain/:id - update meeting" testMeetingUpdate, + test s "PUT /meetings/:domain/:id - update meeting not found (404)" testMeetingUpdateNotFound, + test s "PUT /meetings/:domain/:id - update meeting unauthorized (404)" testMeetingUpdateUnauthorized, + test s "DELETE /meetings/:domain/:id - delete meeting" testMeetingDelete, + test s "DELETE /meetings/:domain/:id - delete meeting not found (404)" testMeetingDeleteNotFound, + test s "DELETE /meetings/:domain/:id - delete meeting unauthorized (404)" testMeetingDeleteUnauthorized, + test s "POST /meetings/:domain/:id/invitations - add invitation" testMeetingAddInvitation, + test s "POST /meetings/:domain/:id/invitations - meeting not found (404)" testMeetingAddInvitationNotFound, + test s "POST /meetings/:domain/:id/invitations/:email/delete - remove invitation" testMeetingRemoveInvitation, + test s "POST /meetings/:domain/:id/invitations/:email/delete - meeting not found (404)" testMeetingRemoveInvitationNotFound, + test s "POST /meetings - personal user creates trial meeting" testMeetingCreatePersonalUserTrial, + test s "POST /meetings - non-paying team creates trial meeting" testMeetingCreateNonPayingTeamTrial, + test s "POST /meetings - paying team creates non-trial meeting" testMeetingCreatePayingTeamNonTrial + ] + +testMeetingCreate :: TestM () +testMeetingCreate = do + (owner, _tid) <- createBindingTeam + now <- liftIO getCurrentTime + let startTime = addUTCTime 3600 now + endTime = addUTCTime 7200 now + newMeeting = + object + [ "title" .= ("Team Standup" :: Text), + "start_date" .= startTime, + "end_date" .= endTime, + "invited_emails" .= (["alice@example.com", "bob@example.com"] :: [Text]) + ] + + galley <- viewGalley + r <- + post + ( galley + . paths ["meetings"] + . zUser owner + . zConn "conn" + . json newMeeting + ) + Date: Wed, 10 Dec 2025 12:43:10 +0100 Subject: [PATCH 02/29] fix: rework feature flags (meeting, meeting_premium) --- changelog.d/2-features/WPB-21964 | 4 +- libs/galley-types/src/Galley/Types/Teams.hs | 15 ++- .../src/Wire/API/Routes/Internal/Galley.hs | 3 +- .../Wire/API/Routes/Public/Galley/Feature.hs | 3 +- libs/wire-api/src/Wire/API/Team/Feature.hs | 63 ++++++++---- services/galley/src/Galley/API/Internal.hs | 4 +- services/galley/src/Galley/API/Meetings.hs | 98 +++++++++++++----- .../galley/src/Galley/API/Public/Feature.hs | 3 +- .../galley/src/Galley/API/Teams/Features.hs | 4 +- .../src/Galley/API/Teams/Features/Get.hs | 4 +- .../galley/test/integration/API/Meetings.hs | 99 ++++++++++++++++++- 11 files changed, 243 insertions(+), 57 deletions(-) diff --git a/changelog.d/2-features/WPB-21964 b/changelog.d/2-features/WPB-21964 index 7209df76d6..6e36be0a96 100644 --- a/changelog.d/2-features/WPB-21964 +++ b/changelog.d/2-features/WPB-21964 @@ -1 +1,3 @@ -Add payingTeam feature flag to distinguish paying teams from trial teams. Meetings created by paying team members are marked as non-trial. Public endpoints: GET/PUT /teams/:tid/features/payingTeam. Internal endpoints: GET/PUT/PATCH /i/teams/:tid/features/payingTeam and lock status management. +Add meetingPremium feature flag (renamed from payingTeam) to distinguish premium teams from trial teams. Meetings created by premium team members are marked as non-trial. Public endpoints: GET/PUT /teams/:tid/features/meetingPremium. Internal endpoints: GET/PUT/PATCH /i/teams/:tid/features/meetingPremium and lock status management. + +Add meeting feature flag to control access to the meetings API. When disabled, all meetings endpoints return 403 Forbidden. The feature is enabled and unlocked by default. Public endpoints: GET/PUT /teams/:tid/features/meeting. Internal endpoints: GET/PUT/PATCH /i/teams/:tid/features/meeting and lock status management. diff --git a/libs/galley-types/src/Galley/Types/Teams.hs b/libs/galley-types/src/Galley/Types/Teams.hs index cff0ca4838..ef49bcdb26 100644 --- a/libs/galley-types/src/Galley/Types/Teams.hs +++ b/libs/galley-types/src/Galley/Types/Teams.hs @@ -330,12 +330,19 @@ newtype instance FeatureDefaults StealthUsersConfig deriving (FromJSON) via Defaults (LockableFeature StealthUsersConfig) deriving (ParseFeatureDefaults) via OptionalField StealthUsersConfig -newtype instance FeatureDefaults PayingTeamConfig - = PayingTeamDefaults (LockableFeature PayingTeamConfig) +newtype instance FeatureDefaults MeetingConfig + = MeetingDefaults (LockableFeature MeetingConfig) deriving stock (Eq, Show) deriving newtype (Default, GetFeatureDefaults) - deriving (FromJSON) via Defaults (LockableFeature PayingTeamConfig) - deriving (ParseFeatureDefaults) via OptionalField PayingTeamConfig + deriving (FromJSON) via Defaults (LockableFeature MeetingConfig) + deriving (ParseFeatureDefaults) via OptionalField MeetingConfig + +newtype instance FeatureDefaults MeetingPremiumConfig + = MeetingPremiumDefaults (LockableFeature MeetingPremiumConfig) + deriving stock (Eq, Show) + deriving newtype (Default, GetFeatureDefaults) + deriving (FromJSON) via Defaults (LockableFeature MeetingPremiumConfig) + deriving (ParseFeatureDefaults) via OptionalField MeetingPremiumConfig featureKey :: forall cfg. (IsFeatureConfig cfg) => Key.Key featureKey = Key.fromText $ featureName @cfg diff --git a/libs/wire-api/src/Wire/API/Routes/Internal/Galley.hs b/libs/wire-api/src/Wire/API/Routes/Internal/Galley.hs index 74163616c0..98d688df0a 100644 --- a/libs/wire-api/src/Wire/API/Routes/Internal/Galley.hs +++ b/libs/wire-api/src/Wire/API/Routes/Internal/Galley.hs @@ -94,7 +94,8 @@ type IFeatureAPI = :<|> IFeatureStatusLockStatusPut AppsConfig :<|> IFeatureStatusLockStatusPut SimplifiedUserConnectionRequestQRCodeConfig :<|> IFeatureStatusLockStatusPut StealthUsersConfig - :<|> IFeatureStatusLockStatusPut PayingTeamConfig + :<|> IFeatureStatusLockStatusPut MeetingConfig + :<|> IFeatureStatusLockStatusPut MeetingPremiumConfig -- all feature configs :<|> Named "feature-configs-internal" diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Galley/Feature.hs b/libs/wire-api/src/Wire/API/Routes/Public/Galley/Feature.hs index 4b83700692..9d3b3b89c4 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Galley/Feature.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Galley/Feature.hs @@ -78,7 +78,8 @@ type FeatureAPI = :<|> FeatureAPIGet SimplifiedUserConnectionRequestQRCodeConfig :<|> FeatureAPIGet StealthUsersConfig :<|> FeatureAPIGet CellsInternalConfig - :<|> FeatureAPIGetPut PayingTeamConfig + :<|> FeatureAPIGetPut MeetingConfig + :<|> FeatureAPIGetPut MeetingPremiumConfig type VersionedFeatureAPIPut named reqBodyVersion cfg = Named diff --git a/libs/wire-api/src/Wire/API/Team/Feature.hs b/libs/wire-api/src/Wire/API/Team/Feature.hs index a982769840..7f615cf425 100644 --- a/libs/wire-api/src/Wire/API/Team/Feature.hs +++ b/libs/wire-api/src/Wire/API/Team/Feature.hs @@ -111,7 +111,8 @@ module Wire.API.Team.Feature AppsConfig (..), SimplifiedUserConnectionRequestQRCodeConfig (..), StealthUsersConfig (..), - PayingTeamConfig (..), + MeetingConfig (..), + MeetingPremiumConfig (..), Features, AllFeatures, NpProject (..), @@ -276,7 +277,8 @@ data FeatureSingleton cfg where FeatureSingletonAssetAuditLogConfig :: FeatureSingleton AssetAuditLogConfig FeatureSingletonStealthUsersConfig :: FeatureSingleton StealthUsersConfig FeatureSingletonCellsInternalConfig :: FeatureSingleton CellsInternalConfig - FeatureSingletonPayingTeamConfig :: FeatureSingleton PayingTeamConfig + FeatureSingletonMeetingConfig :: FeatureSingleton MeetingConfig + FeatureSingletonMeetingPremiumConfig :: FeatureSingleton MeetingPremiumConfig type family DeprecatedFeatureName (v :: Version) (cfg :: Type) :: Symbol @@ -2052,28 +2054,54 @@ instance IsFeatureConfig StealthUsersConfig where featureSingleton = FeatureSingletonStealthUsersConfig -------------------------------------------------------------------------------- --- PayingTeam Feature +-- Meeting Feature -- --- Indicates whether a team is a paying customer. When enabled, meetings created --- by team members are not marked as trial. When disabled, meetings are trial. +-- Controls whether meetings functionality is available. When enabled, users can +-- create and manage meetings. When disabled, meeting endpoints are not accessible. -data PayingTeamConfig = PayingTeamConfig +data MeetingConfig = MeetingConfig deriving (Eq, Show, Generic, GSOP.Generic) - deriving (Arbitrary) via (GenericUniform PayingTeamConfig) - deriving (RenderableSymbol) via (RenderableTypeName PayingTeamConfig) - deriving (ParseDbFeature, Default) via TrivialFeature PayingTeamConfig + deriving (Arbitrary) via (GenericUniform MeetingConfig) + deriving (RenderableSymbol) via (RenderableTypeName MeetingConfig) + deriving (ParseDbFeature, Default) via TrivialFeature MeetingConfig -instance ToSchema PayingTeamConfig where - schema = object "PayingTeamConfig" objectSchema +instance ToSchema MeetingConfig where + schema = object "MeetingConfig" objectSchema -instance Default (LockableFeature PayingTeamConfig) where +instance Default (LockableFeature MeetingConfig) where def = defUnlockedFeature -instance IsFeatureConfig PayingTeamConfig where - type FeatureSymbol PayingTeamConfig = "payingTeam" - featureSingleton = FeatureSingletonPayingTeamConfig +instance IsFeatureConfig MeetingConfig where + type FeatureSymbol MeetingConfig = "meeting" + featureSingleton = FeatureSingletonMeetingConfig - objectSchema = pure PayingTeamConfig +instance ToObjectSchema MeetingConfig where + objectSchema = pure MeetingConfig + +-------------------------------------------------------------------------------- +-- MeetingPremium Feature +-- +-- Indicates whether a team has premium meeting features. When enabled, meetings +-- created by team members are not marked as trial. When disabled, meetings are trial. + +data MeetingPremiumConfig = MeetingPremiumConfig + deriving (Eq, Show, Generic, GSOP.Generic) + deriving (Arbitrary) via (GenericUniform MeetingPremiumConfig) + deriving (RenderableSymbol) via (RenderableTypeName MeetingPremiumConfig) + deriving (ParseDbFeature, Default) via TrivialFeature MeetingPremiumConfig + +instance ToSchema MeetingPremiumConfig where + schema = object "MeetingPremiumConfig" objectSchema + +instance Default (LockableFeature MeetingPremiumConfig) where + def = defUnlockedFeature + +instance IsFeatureConfig MeetingPremiumConfig where + type FeatureSymbol MeetingPremiumConfig = "meetingPremium" + featureSingleton = FeatureSingletonMeetingPremiumConfig + +instance ToObjectSchema MeetingPremiumConfig where + objectSchema = pure MeetingPremiumConfig --------------------------------------------------------------------------------- -- FeatureStatus @@ -2169,7 +2197,8 @@ type Features = AssetAuditLogConfig, StealthUsersConfig, CellsInternalConfig, - PayingTeamConfig + MeetingConfig, + MeetingPremiumConfig ] -- | list of available features as a record diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index f8511e1993..356580e758 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -293,6 +293,7 @@ allFeaturesAPI = <@> featureAPI1Full <@> featureAPI1Full <@> featureAPI1Full + <@> featureAPI1Full featureAPI :: API IFeatureAPI GalleyEffects featureAPI = @@ -316,7 +317,8 @@ featureAPI = <@> mkNamedAPI @'("ilock", AppsConfig) (updateLockStatus @AppsConfig) <@> mkNamedAPI @'("ilock", SimplifiedUserConnectionRequestQRCodeConfig) (updateLockStatus @SimplifiedUserConnectionRequestQRCodeConfig) <@> mkNamedAPI @'("ilock", StealthUsersConfig) (updateLockStatus @StealthUsersConfig) - <@> mkNamedAPI @'("ilock", PayingTeamConfig) (updateLockStatus @PayingTeamConfig) + <@> mkNamedAPI @'("ilock", MeetingConfig) (updateLockStatus @MeetingConfig) + <@> mkNamedAPI @'("ilock", MeetingPremiumConfig) (updateLockStatus @MeetingPremiumConfig) -- all features <@> mkNamedAPI @"feature-configs-internal" (maybe getAllTeamFeaturesForServer getAllTeamFeaturesForUser) diff --git a/services/galley/src/Galley/API/Meetings.hs b/services/galley/src/Galley/API/Meetings.hs index b974d84e57..877a32f30a 100644 --- a/services/galley/src/Galley/API/Meetings.hs +++ b/services/galley/src/Galley/API/Meetings.hs @@ -45,13 +45,31 @@ import Wire.API.Error.Galley import Wire.API.Federation.Client (FederatorClient) import Wire.API.Federation.Error import Wire.API.Meeting -import Wire.API.Team.Feature (FeatureStatus (..), LockableFeature (..), PayingTeamConfig) +import Wire.API.Team.Feature (FeatureStatus (..), LockableFeature (..), MeetingConfig, MeetingPremiumConfig) import Wire.FederationAPIAccess () import Wire.MeetingsSubsystem qualified as Meetings import Wire.NotificationSubsystem import Wire.Sem.Now (Now) import Wire.TeamStore qualified as TeamStore +-- | Check if meetings feature is enabled for the user (if they're in a team) +checkMeetingsEnabled :: + ( Member TeamStore r, + Member TeamFeatureStore r, + Member (ErrorS 'InvalidOperation) r, + Member (Input Opts) r + ) => + UserId -> + Sem r () +checkMeetingsEnabled userId = do + maybeTeamId <- TeamStore.getOneUserTeam userId + case maybeTeamId of + Nothing -> pure () -- Personal users can use meetings + Just teamId -> do + meetingFeature <- getFeatureForTeam @MeetingConfig teamId + unless (meetingFeature.status == FeatureStatusEnabled) $ + throwS @'InvalidOperation + createMeeting :: ( Member Meetings.MeetingsSubsystem r, Member (ErrorS 'InvalidOperation) r, @@ -73,39 +91,46 @@ createMeeting :: NewMeeting -> Sem r Meeting createMeeting lUser newMeeting = do + -- Check if meetings feature is enabled + checkMeetingsEnabled (tUnqualified lUser) + -- Validate that endDate > startDate when (newMeeting.endDate <= newMeeting.startDate) $ throwS @'InvalidOperation - -- Determine trial status based on team membership and paying team feature - trial <- do - maybeTeamId <- TeamStore.getOneUserTeam (tUnqualified lUser) - case maybeTeamId of - Nothing -> pure True -- Personal users are trial - Just teamId -> do - -- Verify user is a team member (not just a collaborator) - maybeMember <- TeamStore.getTeamMember teamId (tUnqualified lUser) - case maybeMember of - Nothing -> throwS @'NotATeamMember -- User not a member - Just _member -> do - -- Check paying team feature status - payingFeature <- getFeatureForTeam @PayingTeamConfig teamId - pure $ case payingFeature of - LockableFeature {status = FeatureStatusEnabled} -> False -- paying team, not trial - _ -> True -- non-paying team or disabled, is trial + -- Determine trial status based on team membership and premium feature + maybeTeamId <- TeamStore.getOneUserTeam (tUnqualified lUser) + trial <- case maybeTeamId of + Nothing -> pure True -- Personal users create trial meetings + Just teamId -> do + -- Verify user is a team member (not just a collaborator) + maybeMember <- TeamStore.getTeamMember teamId (tUnqualified lUser) + case maybeMember of + Nothing -> throwS @'NotATeamMember -- User not a member + Just _member -> do + -- Check meeting premium feature status to determine trial + premiumFeature <- getFeatureForTeam @MeetingPremiumConfig teamId + pure $ case premiumFeature of + LockableFeature {status = FeatureStatusEnabled} -> False -- premium team, not trial + _ -> True -- non-premium team or disabled, is trial (meeting, conversation) <- Meetings.createMeeting lUser newMeeting trial notifyCreatedConversation lUser Nothing conversation InternalAdd pure meeting getMeeting :: ( Member Meetings.MeetingsSubsystem r, - Member (ErrorS 'MeetingNotFound) r + Member (ErrorS 'MeetingNotFound) r, + Member TeamStore r, + Member TeamFeatureStore r, + Member (ErrorS 'InvalidOperation) r, + Member (Input Opts) r ) => Local UserId -> Domain -> MeetingId -> Sem r Meeting getMeeting zUser domain meetingId = do + checkMeetingsEnabled (tUnqualified zUser) let qMeetingId = Qualified meetingId domain maybeMeeting <- Meetings.getMeeting zUser qMeetingId case maybeMeeting of @@ -113,16 +138,25 @@ getMeeting zUser domain meetingId = do Just meeting -> pure meeting listMeetings :: - ( Member Meetings.MeetingsSubsystem r + ( Member Meetings.MeetingsSubsystem r, + Member TeamStore r, + Member TeamFeatureStore r, + Member (ErrorS 'InvalidOperation) r, + Member (Input Opts) r ) => Local UserId -> Sem r [Meeting] -listMeetings = Meetings.listMeetings +listMeetings lUser = do + checkMeetingsEnabled (tUnqualified lUser) + Meetings.listMeetings lUser updateMeeting :: ( Member Meetings.MeetingsSubsystem r, Member (ErrorS 'MeetingNotFound) r, - Member (ErrorS 'InvalidOperation) r + Member (ErrorS 'InvalidOperation) r, + Member TeamStore r, + Member TeamFeatureStore r, + Member (Input Opts) r ) => Local UserId -> Domain -> @@ -130,6 +164,7 @@ updateMeeting :: UpdateMeeting -> Sem r Meeting updateMeeting zUser domain meetingId update = do + checkMeetingsEnabled (tUnqualified zUser) -- Validate that at least one field is being updated when (isNothing update.title && isNothing update.startDate && isNothing update.endDate && isNothing update.recurrence) $ throwS @'InvalidOperation @@ -145,20 +180,29 @@ updateMeeting zUser domain meetingId update = do deleteMeeting :: ( Member Meetings.MeetingsSubsystem r, - Member (ErrorS 'MeetingNotFound) r + Member (ErrorS 'MeetingNotFound) r, + Member (ErrorS 'InvalidOperation) r, + Member TeamStore r, + Member TeamFeatureStore r, + Member (Input Opts) r ) => Local UserId -> Domain -> MeetingId -> Sem r () deleteMeeting zUser domain meetingId = do + checkMeetingsEnabled (tUnqualified zUser) let qMeetingId = Qualified meetingId domain success <- Meetings.deleteMeeting zUser qMeetingId unless success $ throwS @'MeetingNotFound addMeetingInvitation :: ( Member Meetings.MeetingsSubsystem r, - Member (ErrorS 'MeetingNotFound) r + Member (ErrorS 'MeetingNotFound) r, + Member (ErrorS 'InvalidOperation) r, + Member TeamStore r, + Member TeamFeatureStore r, + Member (Input Opts) r ) => Local UserId -> Domain -> @@ -166,13 +210,18 @@ addMeetingInvitation :: MeetingEmailsInvitation -> Sem r () addMeetingInvitation zUser domain meetingId (MeetingEmailsInvitation emails) = do + checkMeetingsEnabled (tUnqualified zUser) let qMeetingId = Qualified meetingId domain success <- Meetings.addInvitedEmails zUser qMeetingId emails unless success $ throwS @'MeetingNotFound removeMeetingInvitation :: ( Member Meetings.MeetingsSubsystem r, - Member (ErrorS 'MeetingNotFound) r + Member (ErrorS 'MeetingNotFound) r, + Member (ErrorS 'InvalidOperation) r, + Member TeamStore r, + Member TeamFeatureStore r, + Member (Input Opts) r ) => Local UserId -> Domain -> @@ -180,6 +229,7 @@ removeMeetingInvitation :: MeetingEmailsInvitation -> Sem r () removeMeetingInvitation zUser domain meetingId (MeetingEmailsInvitation emails) = do + checkMeetingsEnabled (tUnqualified zUser) let qMeetingId = Qualified meetingId domain success <- Meetings.removeInvitedEmails zUser qMeetingId emails unless success $ throwS @'MeetingNotFound diff --git a/services/galley/src/Galley/API/Public/Feature.hs b/services/galley/src/Galley/API/Public/Feature.hs index a7192fe39b..dff22ef12b 100644 --- a/services/galley/src/Galley/API/Public/Feature.hs +++ b/services/galley/src/Galley/API/Public/Feature.hs @@ -78,7 +78,8 @@ featureAPI = <@> mkNamedAPI @'("get", SimplifiedUserConnectionRequestQRCodeConfig) getFeature <@> mkNamedAPI @'("get", StealthUsersConfig) getFeature <@> mkNamedAPI @'("get", CellsInternalConfig) getFeature - <@> featureAPIGetPut + <@> featureAPIGetPut @MeetingConfig + <@> featureAPIGetPut @MeetingPremiumConfig deprecatedFeatureConfigAPI :: API DeprecatedFeatureAPI GalleyEffects deprecatedFeatureConfigAPI = diff --git a/services/galley/src/Galley/API/Teams/Features.hs b/services/galley/src/Galley/API/Teams/Features.hs index dbc53ddcd5..00befc792b 100644 --- a/services/galley/src/Galley/API/Teams/Features.hs +++ b/services/galley/src/Galley/API/Teams/Features.hs @@ -486,4 +486,6 @@ instance SetFeatureConfig SimplifiedUserConnectionRequestQRCodeConfig instance SetFeatureConfig StealthUsersConfig -instance SetFeatureConfig PayingTeamConfig +instance SetFeatureConfig MeetingConfig + +instance SetFeatureConfig MeetingPremiumConfig diff --git a/services/galley/src/Galley/API/Teams/Features/Get.hs b/services/galley/src/Galley/API/Teams/Features/Get.hs index 644de12fb0..a990541e23 100644 --- a/services/galley/src/Galley/API/Teams/Features/Get.hs +++ b/services/galley/src/Galley/API/Teams/Features/Get.hs @@ -428,7 +428,9 @@ instance GetFeatureConfig SimplifiedUserConnectionRequestQRCodeConfig instance GetFeatureConfig StealthUsersConfig -instance GetFeatureConfig PayingTeamConfig +instance GetFeatureConfig MeetingConfig + +instance GetFeatureConfig MeetingPremiumConfig -- | If second factor auth is enabled, make sure that end-points that don't support it, but -- should, are blocked completely. (This is a workaround until we have 2FA for those diff --git a/services/galley/test/integration/API/Meetings.hs b/services/galley/test/integration/API/Meetings.hs index 6141575db5..d54e2193ce 100644 --- a/services/galley/test/integration/API/Meetings.hs +++ b/services/galley/test/integration/API/Meetings.hs @@ -61,7 +61,9 @@ tests s = test s "POST /meetings/:domain/:id/invitations/:email/delete - meeting not found (404)" testMeetingRemoveInvitationNotFound, test s "POST /meetings - personal user creates trial meeting" testMeetingCreatePersonalUserTrial, test s "POST /meetings - non-paying team creates trial meeting" testMeetingCreateNonPayingTeamTrial, - test s "POST /meetings - paying team creates non-trial meeting" testMeetingCreatePayingTeamNonTrial + test s "POST /meetings - paying team creates non-trial meeting" testMeetingCreatePayingTeamNonTrial, + test s "POST /meetings - disabled MeetingConfig blocks creation" testMeetingConfigDisabledBlocksCreate, + test s "GET /meetings - disabled MeetingConfig blocks listing" testMeetingConfigDisabledBlocksList ] testMeetingCreate :: TestM () @@ -579,12 +581,12 @@ testMeetingCreateNonPayingTeamTrial :: TestM () testMeetingCreateNonPayingTeamTrial = do (owner, tid) <- createBindingTeam - -- Ensure payingTeam feature is disabled (default) + -- Ensure meetingPremium feature is disabled (default) g <- viewGalley void $ put ( g - . paths ["i", "teams", toByteString' tid, "features", "payingTeam"] + . paths ["i", "teams", toByteString' tid, "features", "meetingPremium"] . json (object ["status" .= ("disabled" :: Text)]) ) Date: Sat, 13 Dec 2025 16:12:50 +0100 Subject: [PATCH 03/29] feat(stern): Add Meeting and MeetingPremium feature flags to Stern API Adds routes for MeetingConfig and MeetingPremiumConfig to the Stern API, including get, put, and lock/unlock routes. Updates the galley helm chart values to include default configurations for Meeting and MeetingPremium feature flags, and ensures these are properly exposed through the ConfigMap. Addresses part of the review comment regarding missing Stern endpoints, helm charts, and background worker config. --- charts/background-worker/templates/configmap.yaml | 4 ++++ charts/galley/templates/configmap.yaml | 8 ++++++++ charts/galley/values.yaml | 8 ++++++++ tools/stern/src/Stern/API.hs | 6 ++++++ tools/stern/src/Stern/API/Routes.hs | 6 ++++++ 5 files changed, 32 insertions(+) diff --git a/charts/background-worker/templates/configmap.yaml b/charts/background-worker/templates/configmap.yaml index 81e78f5ca7..83fd42c963 100644 --- a/charts/background-worker/templates/configmap.yaml +++ b/charts/background-worker/templates/configmap.yaml @@ -97,6 +97,10 @@ data: {{toYaml .backendNotificationPusher | indent 6 }} {{- with .backgroundJobs }} backgroundJobs: +{{ toYaml . | indent 6 }} + {{- end }} + {{- with .meetingsCleanup }} + meetingsCleanup: {{ toYaml . | indent 6 }} {{- end }} {{- if .postgresMigration }} diff --git a/charts/galley/templates/configmap.yaml b/charts/galley/templates/configmap.yaml index 5c9072a516..4d64c9f11f 100644 --- a/charts/galley/templates/configmap.yaml +++ b/charts/galley/templates/configmap.yaml @@ -218,5 +218,13 @@ data: stealthUsers: {{- toYaml .settings.featureFlags.stealthUsers | nindent 10 }} {{- end }} + {{- if .settings.featureFlags.meeting }} + meeting: + {{- toYaml .settings.featureFlags.meeting | nindent 10 }} + {{- end }} + {{- if .settings.featureFlags.meetingPremium }} + meetingPremium: + {{- toYaml .settings.featureFlags.meetingPremium | nindent 10 }} + {{- end }} {{- end }} {{- end }} diff --git a/charts/galley/values.yaml b/charts/galley/values.yaml index d0ed584bf6..026764909a 100644 --- a/charts/galley/values.yaml +++ b/charts/galley/values.yaml @@ -288,6 +288,14 @@ config: defaults: status: disabled lockStatus: locked + meeting: + defaults: + status: disabled + lockStatus: locked + meetingPremium: + defaults: + status: disabled + lockStatus: locked aws: region: "eu-west-1" proxy: {} diff --git a/tools/stern/src/Stern/API.hs b/tools/stern/src/Stern/API.hs index a741892235..01fb0f364d 100644 --- a/tools/stern/src/Stern/API.hs +++ b/tools/stern/src/Stern/API.hs @@ -192,6 +192,10 @@ sitemap' = :<|> Named @"put-route-apps-config" (mkFeatureStatusPutRoute @AppsConfig) :<|> Named @"get-route-stealth-users-config" (mkFeatureGetRoute @StealthUsersConfig) :<|> Named @"put-route-stealth-users-config" (mkFeatureStatusPutRoute @StealthUsersConfig) + :<|> Named @"get-route-meeting-config" (mkFeatureGetRoute @MeetingConfig) + :<|> Named @"put-route-meeting-config" (mkFeatureStatusPutRoute @MeetingConfig) + :<|> Named @"get-route-meeting-premium-config" (mkFeatureGetRoute @MeetingPremiumConfig) + :<|> Named @"put-route-meeting-premium-config" (mkFeatureStatusPutRoute @MeetingPremiumConfig) :<|> Named @"get-team-invoice" getTeamInvoice :<|> Named @"get-team-billing-info" getTeamBillingInfo :<|> Named @"put-team-billing-info" updateTeamBillingInfo @@ -226,6 +230,8 @@ sitemap' = :<|> Named @"lock-unlock-route-consumable-notifications-config" (mkFeatureLockUnlockRoute @ConsumableNotificationsConfig) :<|> Named @"lock-unlock-route-chat-bubbles-config" (mkFeatureLockUnlockRoute @ChatBubblesConfig) :<|> Named @"lock-unlock-route-apps-config" (mkFeatureLockUnlockRoute @AppsConfig) + :<|> Named @"lock-unlock-route-meeting-config" (mkFeatureLockUnlockRoute @MeetingConfig) + :<|> Named @"lock-unlock-route-meeting-premium-config" (mkFeatureLockUnlockRoute @MeetingPremiumConfig) sitemapInternal :: Servant.Server SternAPIInternal sitemapInternal = diff --git a/tools/stern/src/Stern/API/Routes.hs b/tools/stern/src/Stern/API/Routes.hs index b08a9f9c64..905cd65ebd 100644 --- a/tools/stern/src/Stern/API/Routes.hs +++ b/tools/stern/src/Stern/API/Routes.hs @@ -327,6 +327,10 @@ type SternAPI = :<|> Named "put-route-apps-config" (MkFeatureStatusPutRoute AppsConfig) :<|> Named "get-route-stealth-users-config" (MkFeatureGetRoute StealthUsersConfig) :<|> Named "put-route-stealth-users-config" (MkFeatureStatusPutRoute StealthUsersConfig) + :<|> Named "get-route-meeting-config" (MkFeatureGetRoute MeetingConfig) + :<|> Named "put-route-meeting-config" (MkFeatureStatusPutRoute MeetingConfig) + :<|> Named "get-route-meeting-premium-config" (MkFeatureGetRoute MeetingPremiumConfig) + :<|> Named "put-route-meeting-premium-config" (MkFeatureStatusPutRoute MeetingPremiumConfig) :<|> Named "get-team-invoice" ( Summary "Get a specific invoice by Number" @@ -478,6 +482,8 @@ type SternAPI = :<|> Named "lock-unlock-route-consumable-notifications-config" (MkFeatureLockUnlockRoute ConsumableNotificationsConfig) :<|> Named "lock-unlock-route-chat-bubbles-config" (MkFeatureLockUnlockRoute ChatBubblesConfig) :<|> Named "lock-unlock-route-apps-config" (MkFeatureLockUnlockRoute AppsConfig) + :<|> Named "lock-unlock-route-meeting-config" (MkFeatureLockUnlockRoute MeetingConfig) + :<|> Named "lock-unlock-route-meeting-premium-config" (MkFeatureLockUnlockRoute MeetingPremiumConfig) ------------------------------------------------------------------------------- -- Swagger From ab53c0e3d43db8cf4949e46baa0f6f6842a9a249 Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Sat, 13 Dec 2025 19:34:29 +0100 Subject: [PATCH 04/29] feat(meetings): Replace payingTeam with meeting and meetingPremium feature flags The `payingTeam` feature flag is replaced by two new feature flags: - `meeting`: Controls access to the meetings API. When disabled, all meetings endpoints return 403 Forbidden. The feature is enabled and unlocked by default. - `meetingPremium`: Indicates whether a team has premium meeting features. When enabled, meetings created by team members are not marked as trial. This change also includes: - Renaming the `PayingTeam` feature flag test to `Meeting`. - Adding a new `MeetingPremium` feature flag test. - Updating helm charts and integration configurations. --- changelog.d/2-features/WPB-21964 | 2 +- charts/galley/values.yaml | 8 ++--- .../dockerephemeral/federation-v0/galley.yaml | 8 +++++ .../dockerephemeral/federation-v1/galley.yaml | 8 +++++ .../dockerephemeral/federation-v2/galley.yaml | 8 +++++ integration/integration.cabal | 3 +- .../{PayingTeam.hs => Meeting.hs} | 12 +++---- .../test/Test/FeatureFlags/MeetingPremium.hs | 31 +++++++++++++++++++ integration/test/Test/FeatureFlags/Util.hs | 5 ++- services/galley/galley.integration.yaml | 8 +++++ 10 files changed, 80 insertions(+), 13 deletions(-) rename integration/test/Test/FeatureFlags/{PayingTeam.hs => Meeting.hs} (77%) create mode 100644 integration/test/Test/FeatureFlags/MeetingPremium.hs diff --git a/changelog.d/2-features/WPB-21964 b/changelog.d/2-features/WPB-21964 index 6e36be0a96..13d16c8ddf 100644 --- a/changelog.d/2-features/WPB-21964 +++ b/changelog.d/2-features/WPB-21964 @@ -1,3 +1,3 @@ -Add meetingPremium feature flag (renamed from payingTeam) to distinguish premium teams from trial teams. Meetings created by premium team members are marked as non-trial. Public endpoints: GET/PUT /teams/:tid/features/meetingPremium. Internal endpoints: GET/PUT/PATCH /i/teams/:tid/features/meetingPremium and lock status management. +Add meetingPremium feature flag to distinguish premium teams from trial teams. Meetings created by premium team members are marked as non-trial. Public endpoints: GET/PUT /teams/:tid/features/meetingPremium. Internal endpoints: GET/PUT/PATCH /i/teams/:tid/features/meetingPremium and lock status management. Add meeting feature flag to control access to the meetings API. When disabled, all meetings endpoints return 403 Forbidden. The feature is enabled and unlocked by default. Public endpoints: GET/PUT /teams/:tid/features/meeting. Internal endpoints: GET/PUT/PATCH /i/teams/:tid/features/meeting and lock status management. diff --git a/charts/galley/values.yaml b/charts/galley/values.yaml index 026764909a..8e328671d4 100644 --- a/charts/galley/values.yaml +++ b/charts/galley/values.yaml @@ -290,12 +290,12 @@ config: lockStatus: locked meeting: defaults: - status: disabled - lockStatus: locked + status: enabled + lockStatus: unlocked meetingPremium: defaults: - status: disabled - lockStatus: locked + status: enabled + lockStatus: unlocked aws: region: "eu-west-1" proxy: {} diff --git a/deploy/dockerephemeral/federation-v0/galley.yaml b/deploy/dockerephemeral/federation-v0/galley.yaml index ab2644a8ef..5be62c125a 100644 --- a/deploy/dockerephemeral/federation-v0/galley.yaml +++ b/deploy/dockerephemeral/federation-v0/galley.yaml @@ -83,6 +83,14 @@ settings: verificationExpiration: 86400 acmeDiscoveryUrl: null lockStatus: unlocked + meeting: + defaults: + status: enabled + lockStatus: unlocked + meetingPremium: + defaults: + status: enabled + lockStatus: unlocked logLevel: Warn logNetStrings: false diff --git a/deploy/dockerephemeral/federation-v1/galley.yaml b/deploy/dockerephemeral/federation-v1/galley.yaml index f272536260..d4a5070163 100644 --- a/deploy/dockerephemeral/federation-v1/galley.yaml +++ b/deploy/dockerephemeral/federation-v1/galley.yaml @@ -97,6 +97,14 @@ settings: limitedEventFanout: defaults: status: disabled + meeting: + defaults: + status: enabled + lockStatus: unlocked + meetingPremium: + defaults: + status: enabled + lockStatus: unlocked logLevel: Warn logNetStrings: false diff --git a/deploy/dockerephemeral/federation-v2/galley.yaml b/deploy/dockerephemeral/federation-v2/galley.yaml index 94d268ae0e..4b8257f986 100644 --- a/deploy/dockerephemeral/federation-v2/galley.yaml +++ b/deploy/dockerephemeral/federation-v2/galley.yaml @@ -146,6 +146,14 @@ settings: defaults: status: enabled lockStatus: unlocked + meeting: + defaults: + status: enabled + lockStatus: unlocked + meetingPremium: + defaults: + status: enabled + lockStatus: unlocked logLevel: Warn logNetStrings: false diff --git a/integration/integration.cabal b/integration/integration.cabal index 96444950b2..555ca6a7f1 100644 --- a/integration/integration.cabal +++ b/integration/integration.cabal @@ -153,11 +153,12 @@ library Test.FeatureFlags.FileSharing Test.FeatureFlags.GuestLinks Test.FeatureFlags.LegalHold + Test.FeatureFlags.Meeting + Test.FeatureFlags.MeetingPremium Test.FeatureFlags.Mls Test.FeatureFlags.MlsE2EId Test.FeatureFlags.MlsMigration Test.FeatureFlags.OutlookCalIntegration - Test.FeatureFlags.PayingTeam Test.FeatureFlags.SearchVisibilityAvailable Test.FeatureFlags.SearchVisibilityInbound Test.FeatureFlags.SelfDeletingMessages diff --git a/integration/test/Test/FeatureFlags/PayingTeam.hs b/integration/test/Test/FeatureFlags/Meeting.hs similarity index 77% rename from integration/test/Test/FeatureFlags/PayingTeam.hs rename to integration/test/Test/FeatureFlags/Meeting.hs index e14d3cd6ad..afd828871e 100644 --- a/integration/test/Test/FeatureFlags/PayingTeam.hs +++ b/integration/test/Test/FeatureFlags/Meeting.hs @@ -15,17 +15,17 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Test.FeatureFlags.PayingTeam where +module Test.FeatureFlags.Meeting where import Test.FeatureFlags.Util import Testlib.Prelude -testPatchPayingTeam :: (HasCallStack) => App () -testPatchPayingTeam = checkPatch OwnDomain "payingTeam" disabled +testPatchMeeting :: (HasCallStack) => App () +testPatchMeeting = checkPatch OwnDomain "meeting" disabled -testPayingTeam :: (HasCallStack) => APIAccess -> App () -testPayingTeam access = - mkFeatureTests "payingTeam" +testMeeting :: (HasCallStack) => APIAccess -> App () +testMeeting access = + mkFeatureTests "meeting" & addUpdate disabled & addUpdate enabled & runFeatureTests OwnDomain access diff --git a/integration/test/Test/FeatureFlags/MeetingPremium.hs b/integration/test/Test/FeatureFlags/MeetingPremium.hs new file mode 100644 index 0000000000..fcf26876c3 --- /dev/null +++ b/integration/test/Test/FeatureFlags/MeetingPremium.hs @@ -0,0 +1,31 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2025 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.FeatureFlags.MeetingPremium where + +import Test.FeatureFlags.Util +import Testlib.Prelude + +testPatchMeetingPremium :: (HasCallStack) => App () +testPatchMeetingPremium = checkPatch OwnDomain "meetingPremium" disabled + +testMeetingPremium :: (HasCallStack) => APIAccess -> App () +testMeetingPremium access = + mkFeatureTests "meetingPremium" + & addUpdate disabled + & addUpdate enabled + & runFeatureTests OwnDomain access diff --git a/integration/test/Test/FeatureFlags/Util.hs b/integration/test/Test/FeatureFlags/Util.hs index 206cc30b70..21b17059ec 100644 --- a/integration/test/Test/FeatureFlags/Util.hs +++ b/integration/test/Test/FeatureFlags/Util.hs @@ -241,7 +241,8 @@ defAllFeatures = "storage" .= object ["teamQuotaBytes" .= "1000000000000"] ] ], - "payingTeam" .= disabled + "meeting" .= enabled, + "meetingPremium" .= enabled ] hasExplicitLockStatus :: String -> Bool @@ -253,6 +254,8 @@ hasExplicitLockStatus "sndFactorPasswordChallenge" = True hasExplicitLockStatus "outlookCalIntegration" = True hasExplicitLockStatus "enforceFileDownloadLocation" = True hasExplicitLockStatus "domainRegistration" = True +hasExplicitLockStatus "meeting" = True +hasExplicitLockStatus "meetingPremium" = True hasExplicitLockStatus _ = False checkFeature :: (HasCallStack, MakesValue user, MakesValue tid) => String -> user -> tid -> Value -> App () diff --git a/services/galley/galley.integration.yaml b/services/galley/galley.integration.yaml index ec5f20aeb3..3170e3cee3 100644 --- a/services/galley/galley.integration.yaml +++ b/services/galley/galley.integration.yaml @@ -228,6 +228,14 @@ settings: defaults: status: disabled lockStatus: locked + meeting: + defaults: + status: enabled + lockStatus: unlocked + meetingPremium: + defaults: + status: enabled + lockStatus: unlocked logLevel: Warn logNetStrings: false From c1e17d66093081117d01cb98350c56bdedf335f3 Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Sat, 13 Dec 2025 19:37:46 +0100 Subject: [PATCH 05/29] fix: schema recurrence field --- postgres-schema.sql | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/postgres-schema.sql b/postgres-schema.sql index ce478aab3d..3c7663f64b 100644 --- a/postgres-schema.sql +++ b/postgres-schema.sql @@ -171,9 +171,10 @@ CREATE TABLE public.meetings ( domain text NOT NULL, title text NOT NULL, creator uuid NOT NULL, + creator_domain text NOT NULL, start_date timestamp with time zone NOT NULL, end_date timestamp with time zone NOT NULL, - schedule text, + recurrence text, conversation_id uuid NOT NULL, conversation_domain text NOT NULL, invited_emails text[] DEFAULT '{}'::text[], @@ -448,7 +449,7 @@ CREATE INDEX conversation_team_idx ON public.conversation USING btree (team); -- Name: idx_meetings_conversation; Type: INDEX; Schema: public; Owner: wire-server -- -CREATE INDEX idx_meetings_conversation ON public.meetings USING btree (conversation_id, conversation_domain); +CREATE INDEX idx_meetings_conversation ON public.meetings USING btree (conversation_domain, conversation_id); -- From 759299a73fb45178b903567905ed509143fab218 Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Sat, 13 Dec 2025 19:44:44 +0100 Subject: [PATCH 06/29] docs(api): frequency doc --- libs/wire-api/src/Wire/API/Meeting.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/libs/wire-api/src/Wire/API/Meeting.hs b/libs/wire-api/src/Wire/API/Meeting.hs index 0a4cbb45b9..f1691e6b2e 100644 --- a/libs/wire-api/src/Wire/API/Meeting.hs +++ b/libs/wire-api/src/Wire/API/Meeting.hs @@ -87,7 +87,8 @@ data NewMeeting = NewMeeting deriving (Arbitrary) via (GenericUniform NewMeeting) data Recurrence = Recurrence - { freq :: Frequency, + { -- | The interval between occurrences, e.g., every 2 weeks for Weekly frequency with interval=2 + freq :: Frequency, interval :: Maybe Int, until :: Maybe UTCTime } From 7e83d14ceb4da6c5dca0dd951f9de3948815247f Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Sat, 13 Dec 2025 19:54:18 +0100 Subject: [PATCH 07/29] docs: Add documentation for meeting and meetingPremium feature flags Adds documentation for the `meeting` and `meetingPremium` feature flags to `docs/src/developer/reference/config-options.md`. --- .../src/developer/reference/config-options.md | 48 +++++++++++++++++++ 1 file changed, 48 insertions(+) diff --git a/docs/src/developer/reference/config-options.md b/docs/src/developer/reference/config-options.md index e6c126e997..d8a59945ad 100644 --- a/docs/src/developer/reference/config-options.md +++ b/docs/src/developer/reference/config-options.md @@ -234,6 +234,54 @@ The `conferenceCalling` section is optional in `featureFlags`. If it is omitted See also: conference falling for personal accounts (below). +### Meetings + +The `meeting` feature flag controls whether a user can initiate a meeting. It is enabled and unlocked by default. If you want a different configuration, use the following syntax: + +```yaml +meeting: + defaults: + status: disabled|enabled + lockStatus: locked|unlocked +``` + +These are all the possible combinations of `status` and `lockStatus`: + +| `status` | `lockStatus` | | +| ---------- | ------------ | ------------------------------------------------- | +| `enabled` | `locked` | Feature enabled, cannot be disabled by team admin | +| `enabled` | `unlocked` | Feature enabled, can be disabled by team admin | +| `disabled` | `locked` | Feature disabled, cannot be enabled by team admin | +| `disabled` | `unlocked` | Feature disabled, can be enabled by team admin | + +The lock status for individual teams can be changed via the internal API (`PUT /i/teams/:tid/features/meeting/(un)?locked`). + +The feature status for individual teams can be changed via the public API (if the feature is unlocked). + +### Meeting Premium + +The `meetingPremium` feature flag controls whether a team has premium meeting features. When enabled, meetings created by team members are not marked as trial. When disabled, meetings are trial and limited to 25 minutes. It is enabled and unlocked by default. If you want a different configuration, use the following syntax: + +```yaml +meetingPremium: + defaults: + status: disabled|enabled + lockStatus: locked|unlocked +``` + +These are all the possible combinations of `status` and `lockStatus`: + +| `status` | `lockStatus` | | +| ---------- | ------------ | ------------------------------------------------- | +| `enabled` | `locked` | Feature enabled, cannot be disabled by team admin | +| `enabled` | `unlocked` | Feature enabled, can be disabled by team admin | +| `disabled` | `locked` | Feature disabled, cannot be enabled by team admin | +| `disabled` | `unlocked` | Feature disabled, can be enabled by team admin | + +The lock status for individual teams can be changed via the internal API (`PUT /i/teams/:tid/features/meetingPremium/(un)?locked`). + +The feature status for individual teams can be changed via the public API (if the feature is unlocked). + ### File Sharing File sharing is enabled and unlocked by default. If you want a different configuration, use the following syntax: From 1ad5e1de90401c3ad1e8353e6c0ef73f6086a3d0 Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Sat, 13 Dec 2025 21:06:10 +0100 Subject: [PATCH 08/29] refactor: move MeetingId to Data.Id --- libs/types-common/src/Data/Id.hs | 7 ++++ libs/wire-api/src/Wire/API/Meeting.hs | 18 ++-------- .../Wire/API/Routes/Public/Galley/Meetings.hs | 1 + .../src/Wire/MeetingsStore/Postgres.hs | 34 +++++++++---------- .../src/Wire/MeetingsSubsystem/Interpreter.hs | 3 +- .../galley/test/integration/API/Meetings.hs | 20 ++++------- 6 files changed, 35 insertions(+), 48 deletions(-) diff --git a/libs/types-common/src/Data/Id.hs b/libs/types-common/src/Data/Id.hs index ce636dae32..ba6e6c21d2 100644 --- a/libs/types-common/src/Data/Id.hs +++ b/libs/types-common/src/Data/Id.hs @@ -57,6 +57,7 @@ module Data.Id OAuthClientId, OAuthRefreshTokenId, ChallengeId, + MeetingId, -- * Utils uuidSchema, @@ -114,6 +115,7 @@ data IdTag | OAuthRefreshToken | Challenge | Job + | Meeting idTagName :: IdTag -> Text idTagName Asset = "Asset" @@ -129,6 +131,7 @@ idTagName OAuthClient = "OAuthClient" idTagName OAuthRefreshToken = "OAuthRefreshToken" idTagName Challenge = "Challenge" idTagName Job = "Job" +idTagName Meeting = "Meeting" class KnownIdTag (t :: IdTag) where idTagValue :: IdTag @@ -157,6 +160,8 @@ instance KnownIdTag 'OAuthRefreshToken where idTagValue = OAuthRefreshToken instance KnownIdTag 'Job where idTagValue = Job +instance KnownIdTag 'Meeting where idTagValue = Meeting + type AssetId = Id 'Asset type InvitationId = Id 'Invitation @@ -185,6 +190,8 @@ type ChallengeId = Id 'Challenge type JobId = Id 'Job +type MeetingId = Id 'Meeting + -- Id ------------------------------------------------------------------------- data NoId = NoId deriving (Eq, Show, Generic) diff --git a/libs/wire-api/src/Wire/API/Meeting.hs b/libs/wire-api/src/Wire/API/Meeting.hs index f1691e6b2e..2587ec661c 100644 --- a/libs/wire-api/src/Wire/API/Meeting.hs +++ b/libs/wire-api/src/Wire/API/Meeting.hs @@ -19,31 +19,17 @@ module Wire.API.Meeting where import Control.Lens ((?~)) import Data.Aeson () -import Data.Id (ConvId, UserId, uuidSchema) +import Data.Id (ConvId, MeetingId, UserId) import Data.Json.Util (utcTimeSchema) import Data.OpenApi qualified as S -import Data.Qualified (Qualified, qualifiedSchema) +import Data.Qualified (Qualified) import Data.Schema import Data.Time.Clock -import Data.UUID (UUID) import Deriving.Aeson import Imports -import Servant (FromHttpApiData, ToHttpApiData) import Wire.API.User.Identity (EmailAddress) import Wire.Arbitrary (Arbitrary, GenericUniform (..)) --- | Unique identifier for a meeting -newtype MeetingId = MeetingId {unMeetingId :: UUID} - deriving stock (Eq, Ord, Show, Generic) - deriving newtype (ToJSON, FromJSON, FromHttpApiData, ToHttpApiData, S.ToSchema, S.ToParamSchema) - deriving (Arbitrary) via (GenericUniform MeetingId) - -instance ToSchema MeetingId where - schema = MeetingId <$> unMeetingId .= uuidSchema - -instance ToSchema (Qualified MeetingId) where - schema = qualifiedSchema "MeetingId" "id" schema - -- | Core Meeting type data Meeting = Meeting { id :: Qualified MeetingId, diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Galley/Meetings.hs b/libs/wire-api/src/Wire/API/Routes/Public/Galley/Meetings.hs index c5fd3fe999..184b275238 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Galley/Meetings.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Galley/Meetings.hs @@ -18,6 +18,7 @@ module Wire.API.Routes.Public.Galley.Meetings where import Data.Domain (Domain) +import Data.Id (MeetingId) import Servant import Wire.API.Error import Wire.API.Error.Galley diff --git a/libs/wire-subsystems/src/Wire/MeetingsStore/Postgres.hs b/libs/wire-subsystems/src/Wire/MeetingsStore/Postgres.hs index 84a85d6b61..225aabdda9 100644 --- a/libs/wire-subsystems/src/Wire/MeetingsStore/Postgres.hs +++ b/libs/wire-subsystems/src/Wire/MeetingsStore/Postgres.hs @@ -77,7 +77,7 @@ createMeetingImpl :: Member (Embed IO) r, Member (Error UsageError) r ) => - Qualified API.MeetingId -> + Qualified MeetingId -> Qualified UserId -> Text -> UTCTime -> @@ -96,7 +96,7 @@ createMeetingImpl qMeetingId qCreator title startDate endDate recurrence qConvId session = statement params insertStatement params = - ( UUID.toText (API.unMeetingId (qUnqualified qMeetingId)), + ( idToText (qUnqualified qMeetingId), _domainText (qDomain qMeetingId), title, toUUID (qUnqualified qCreator), @@ -126,7 +126,7 @@ getMeetingImpl :: Member (Embed IO) r, Member (Error UsageError) r ) => - Qualified API.MeetingId -> + Qualified MeetingId -> Sem r (Maybe API.Meeting) getMeetingImpl qMeetingId = do pool <- input @@ -134,7 +134,7 @@ getMeetingImpl qMeetingId = do either throw pure result where session :: Session (Maybe API.Meeting) - session = statement (_domainText (qDomain qMeetingId), UUID.toText (API.unMeetingId (qUnqualified qMeetingId))) getMeetingStatement + session = statement (_domainText (qDomain qMeetingId), idToText (qUnqualified qMeetingId)) getMeetingStatement getMeetingStatement :: Statement (Text, Text) (Maybe API.Meeting) getMeetingStatement = @@ -215,7 +215,7 @@ updateMeetingImpl :: Member (Embed IO) r, Member (Error UsageError) r ) => - Qualified API.MeetingId -> + Qualified MeetingId -> Maybe Text -> Maybe UTCTime -> Maybe UTCTime -> @@ -234,10 +234,10 @@ updateMeetingImpl qMeetingId mTitle mStartDate mEndDate mRecurrence = do mEndDate, fmap toJSON mRecurrence, _domainText (qDomain qMeetingId), - UUID.toText (API.unMeetingId (qUnqualified qMeetingId)) + idToText (qUnqualified qMeetingId) ) updateStatement - statement (_domainText (qDomain qMeetingId), UUID.toText (API.unMeetingId (qUnqualified qMeetingId))) getMeetingStatement + statement (_domainText (qDomain qMeetingId), idToText (qUnqualified qMeetingId)) getMeetingStatement updateStatement :: Statement (Maybe Text, Maybe UTCTime, Maybe UTCTime, Maybe Value, Text, Text) () updateStatement = @@ -269,7 +269,7 @@ deleteMeetingImpl :: Member (Embed IO) r, Member (Error UsageError) r ) => - Qualified API.MeetingId -> + Qualified MeetingId -> Sem r () deleteMeetingImpl qMeetingId = do pool <- input @@ -277,7 +277,7 @@ deleteMeetingImpl qMeetingId = do either throw pure result where session :: Session () - session = statement (_domainText (qDomain qMeetingId), UUID.toText (API.unMeetingId (qUnqualified qMeetingId))) deleteStatement + session = statement (_domainText (qDomain qMeetingId), idToText (qUnqualified qMeetingId)) deleteStatement deleteStatement :: Statement (Text, Text) () deleteStatement = @@ -291,7 +291,7 @@ addInvitedEmailsImpl :: Member (Embed IO) r, Member (Error UsageError) r ) => - Qualified API.MeetingId -> + Qualified MeetingId -> [EmailAddress] -> Sem r () addInvitedEmailsImpl qMeetingId emails = do @@ -300,7 +300,7 @@ addInvitedEmailsImpl qMeetingId emails = do either throw pure result where session :: Session () - session = statement (V.fromList (fromEmail <$> emails), _domainText (qDomain qMeetingId), UUID.toText (API.unMeetingId (qUnqualified qMeetingId))) addEmailStatement + session = statement (V.fromList (fromEmail <$> emails), _domainText (qDomain qMeetingId), idToText (qUnqualified qMeetingId)) addEmailStatement addEmailStatement :: Statement (V.Vector Text, Text, Text) () addEmailStatement = @@ -315,7 +315,7 @@ removeInvitedEmailsImpl :: Member (Embed IO) r, Member (Error UsageError) r ) => - Qualified API.MeetingId -> + Qualified MeetingId -> [EmailAddress] -> Sem r () removeInvitedEmailsImpl qMeetingId emails = do @@ -324,7 +324,7 @@ removeInvitedEmailsImpl qMeetingId emails = do either throw pure result where session :: Session () - session = statement (V.fromList (fromEmail <$> emails), _domainText (qDomain qMeetingId), UUID.toText (API.unMeetingId (qUnqualified qMeetingId))) removeEmailStatement + session = statement (V.fromList (fromEmail <$> emails), _domainText (qDomain qMeetingId), idToText (qUnqualified qMeetingId)) removeEmailStatement removeEmailStatement :: Statement (V.Vector Text, Text, Text) () removeEmailStatement = @@ -371,7 +371,7 @@ deleteMeetingBatchImpl :: Member (Embed IO) r, Member (Error UsageError) r ) => - [Qualified API.MeetingId] -> + [Qualified MeetingId] -> Sem r Int64 deleteMeetingBatchImpl meetingIds = do pool <- input @@ -381,9 +381,9 @@ deleteMeetingBatchImpl meetingIds = do session :: Session Int64 session = foldM deleteSingle 0 meetingIds - deleteSingle :: Int64 -> Qualified API.MeetingId -> Session Int64 + deleteSingle :: Int64 -> Qualified MeetingId -> Session Int64 deleteSingle acc qMeetingId = do - count <- statement (UUID.toText (API.unMeetingId (qUnqualified qMeetingId)), _domainText (qDomain qMeetingId)) deleteStatement + count <- statement (idToText (qUnqualified qMeetingId), _domainText (qDomain qMeetingId)) deleteStatement pure (acc + count) deleteStatement :: Statement (Text, Text) Int64 @@ -397,7 +397,7 @@ deleteMeetingBatchImpl meetingIds = do rowToMeeting :: (UUID, Text, Text, UUID, Text, UTCTime, UTCTime, Maybe Value, UUID, Text, V.Vector Text, Bool) -> API.Meeting rowToMeeting (meetingIdUUID, domainText_, titleText, creatorUUID, creatorDomainText, startDate', endDate', recurrenceJSON, convIdUUID, convDomainText, emailsVec, trial') = - let meetingId' = API.MeetingId meetingIdUUID + let meetingId' = Id meetingIdUUID domain' = Domain domainText_ qMeetingId = Qualified meetingId' domain' creator' = Id creatorUUID diff --git a/libs/wire-subsystems/src/Wire/MeetingsSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/MeetingsSubsystem/Interpreter.hs index c95ecf2d5c..a70128298f 100644 --- a/libs/wire-subsystems/src/Wire/MeetingsSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/MeetingsSubsystem/Interpreter.hs @@ -21,7 +21,6 @@ import Data.Id import Data.Qualified import Data.Set qualified as Set import Data.Time.Clock (UTCTime) -import Data.UUID.V4 qualified as UUIDV4 import Imports import Polysemy import Wire.API.Conversation hiding (Member) @@ -71,7 +70,7 @@ createMeetingImpl :: Sem r (Meeting, StoredConversation) createMeetingImpl zUser newMeeting trial = do -- Generate meeting ID - meetingId <- liftIO $ MeetingId <$> UUIDV4.nextRandom + meetingId <- randomId let qMeetingId = tUntagged (qualifyAs zUser meetingId) -- Generate new conversation ID diff --git a/services/galley/test/integration/API/Meetings.hs b/services/galley/test/integration/API/Meetings.hs index d54e2193ce..759badbd66 100644 --- a/services/galley/test/integration/API/Meetings.hs +++ b/services/galley/test/integration/API/Meetings.hs @@ -25,10 +25,9 @@ import Bilge hiding (timeout) import Bilge.Assert import Data.Aeson import Data.ByteString.Conversion (toByteString') -import Data.Id (randomId, toUUID) +import Data.Id (MeetingId, idToText, randomId) import Data.Qualified (qDomain, qUnqualified) import Data.Time.Clock -import Data.UUID qualified as UUID import Imports import Test.Tasty import Test.Tasty.HUnit ((@?=)) @@ -39,7 +38,7 @@ import Wire.API.User.Identity (emailAddressText) -- Helper to convert MeetingId to ByteString for URL paths meetingIdToBS :: MeetingId -> ByteString -meetingIdToBS = toByteString' . UUID.toText . unMeetingId +meetingIdToBS = toByteString' . idToText tests :: IO TestSetup -> TestTree tests s = @@ -178,8 +177,7 @@ testMeetingGet = do testMeetingGetNotFound :: TestM () testMeetingGetNotFound = do (owner, _tid) <- createBindingTeam - uuid <- randomId - let fakeMeetingId = MeetingId (toUUID uuid) + fakeMeetingId <- randomId localDomain <- viewFederationDomain galley <- viewGalley @@ -242,8 +240,7 @@ testMeetingUpdate = do testMeetingUpdateNotFound :: TestM () testMeetingUpdateNotFound = do (owner, _tid) <- createBindingTeam - uuid <- randomId - let fakeMeetingId = MeetingId (toUUID uuid) + fakeMeetingId <- randomId localDomain <- viewFederationDomain now <- liftIO getCurrentTime let startTime = addUTCTime 3600 now @@ -358,8 +355,7 @@ testMeetingDelete = do testMeetingDeleteNotFound :: TestM () testMeetingDeleteNotFound = do (owner, _tid) <- createBindingTeam - uuid <- randomId - let fakeMeetingId = MeetingId (toUUID uuid) + fakeMeetingId <- randomId localDomain <- viewFederationDomain galley <- viewGalley @@ -463,8 +459,7 @@ testMeetingAddInvitation = do testMeetingAddInvitationNotFound :: TestM () testMeetingAddInvitationNotFound = do (owner, _tid) <- createBindingTeam - uuid <- randomId - let fakeMeetingId = MeetingId (toUUID uuid) + fakeMeetingId <- randomId localDomain <- viewFederationDomain let invitation = object ["emails" .= ["bob@example.com" :: Text]] @@ -532,8 +527,7 @@ testMeetingRemoveInvitation = do testMeetingRemoveInvitationNotFound :: TestM () testMeetingRemoveInvitationNotFound = do (owner, _tid) <- createBindingTeam - uuid <- randomId - let fakeMeetingId = MeetingId (toUUID uuid) + fakeMeetingId <- randomId localDomain <- viewFederationDomain let removeInvitation = object ["emails" .= ["alice@example.com" :: Text]] From 9c00b5cabe677e6828e2099929b334c33c671562 Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Sat, 13 Dec 2025 22:45:39 +0100 Subject: [PATCH 09/29] feat: Add updated_at column to meetings table and update relevant functions --- libs/wire-api/src/Wire/API/Meeting.hs | 4 ++- .../src/Wire/MeetingsStore/Postgres.hs | 26 +++++++++++-------- .../src/Wire/MeetingsSubsystem/Interpreter.hs | 6 +++-- .../postgresql-migrations/001_meetings.sql | 2 ++ 4 files changed, 24 insertions(+), 14 deletions(-) diff --git a/libs/wire-api/src/Wire/API/Meeting.hs b/libs/wire-api/src/Wire/API/Meeting.hs index 2587ec661c..64194ff5f4 100644 --- a/libs/wire-api/src/Wire/API/Meeting.hs +++ b/libs/wire-api/src/Wire/API/Meeting.hs @@ -40,7 +40,8 @@ data Meeting = Meeting recurrence :: Maybe Recurrence, conversationId :: Qualified ConvId, invitedEmails :: [EmailAddress], - trial :: Bool + trial :: Bool, + updatedAt :: UTCTime } deriving stock (Eq, Show, Generic) deriving (ToJSON, FromJSON, S.ToSchema) via (Schema Meeting) @@ -59,6 +60,7 @@ instance ToSchema Meeting where <*> (.conversationId) .= field "qualified_conversation" schema <*> (.invitedEmails) .= field "invited_emails" (array schema) <*> (.trial) .= field "trial" schema + <*> (.updatedAt) .= field "updated_at" utcTimeSchema -- | Request to create a new meeting data NewMeeting = NewMeeting diff --git a/libs/wire-subsystems/src/Wire/MeetingsStore/Postgres.hs b/libs/wire-subsystems/src/Wire/MeetingsStore/Postgres.hs index 225aabdda9..2460516a9c 100644 --- a/libs/wire-subsystems/src/Wire/MeetingsStore/Postgres.hs +++ b/libs/wire-subsystems/src/Wire/MeetingsStore/Postgres.hs @@ -145,7 +145,7 @@ getMeetingImpl qMeetingId = do SELECT id :: text :: uuid, domain :: text, title :: text, creator :: uuid, creator_domain :: text, start_date :: timestamptz, end_date :: timestamptz, recurrence :: jsonb?, conversation_id :: uuid, conversation_domain :: text, - invited_emails :: text[], trial :: boolean + invited_emails :: text[], trial :: boolean, updated_at :: timestamptz FROM meetings WHERE domain = ($1 :: text) AND id :: text = ($2 :: text) |] @@ -174,7 +174,7 @@ listMeetingsByUserImpl userId = do SELECT id :: text :: uuid, domain :: text, title :: text, creator :: uuid, creator_domain :: text, start_date :: timestamptz, end_date :: timestamptz, recurrence :: jsonb?, conversation_id :: uuid, conversation_domain :: text, - invited_emails :: text[], trial :: boolean + invited_emails :: text[], trial :: boolean, updated_at :: timestamptz FROM meetings WHERE creator = ($1 :: uuid) ORDER BY start_date ASC @@ -204,7 +204,7 @@ listMeetingsByConversationImpl qConvId = do SELECT id :: text :: uuid, domain :: text, title :: text, creator :: uuid, creator_domain :: text, start_date :: timestamptz, end_date :: timestamptz, recurrence :: jsonb?, conversation_id :: uuid, conversation_domain :: text, - invited_emails :: text[], trial :: boolean + invited_emails :: text[], trial :: boolean, updated_at :: timestamptz FROM meetings WHERE conversation_id = ($1 :: uuid) AND conversation_domain = ($2 :: text) ORDER BY start_date ASC @@ -246,7 +246,8 @@ updateMeetingImpl qMeetingId mTitle mStartDate mEndDate mRecurrence = do SET title = COALESCE($1 :: text?, title), start_date = COALESCE($2 :: timestamptz?, start_date), end_date = COALESCE($3 :: timestamptz?, end_date), - recurrence = COALESCE($4 :: jsonb?, recurrence) + recurrence = COALESCE($4 :: jsonb?, recurrence), + updated_at = NOW() WHERE domain = ($5 :: text) AND id :: text = ($6 :: text) |] @@ -259,7 +260,7 @@ updateMeetingImpl qMeetingId mTitle mStartDate mEndDate mRecurrence = do SELECT id :: text :: uuid, domain :: text, title :: text, creator :: uuid, creator_domain :: text, start_date :: timestamptz, end_date :: timestamptz, recurrence :: jsonb?, conversation_id :: uuid, conversation_domain :: text, - invited_emails :: text[], trial :: boolean + invited_emails :: text[], trial :: boolean, updated_at :: timestamptz FROM meetings WHERE domain = ($1 :: text) AND id :: text = ($2 :: text) |] @@ -306,7 +307,8 @@ addInvitedEmailsImpl qMeetingId emails = do addEmailStatement = [resultlessStatement| UPDATE meetings - SET invited_emails = array_cat(invited_emails, $1 :: text[]) + SET invited_emails = array_cat(invited_emails, $1 :: text[]), + updated_at = NOW() WHERE domain = ($2 :: text) AND id :: text = ($3 :: text) |] @@ -330,7 +332,8 @@ removeInvitedEmailsImpl qMeetingId emails = do removeEmailStatement = [resultlessStatement| UPDATE meetings M - SET invited_emails = (SELECT array(SELECT unnest(M.invited_emails) EXCEPT SELECT unnest($1 :: text[]))) + SET invited_emails = (SELECT array(SELECT unnest(M.invited_emails) EXCEPT SELECT unnest($1 :: text[]))), + updated_at = NOW() WHERE domain = ($2 :: text) AND id :: text = ($3 :: text) |] @@ -359,7 +362,7 @@ getOldMeetingsImpl cutoffTime batchSize = do SELECT id :: uuid, domain :: text, title :: text, creator :: uuid, creator_domain :: text, start_date :: timestamptz, end_date :: timestamptz, recurrence :: jsonb?, conversation_id :: uuid, conversation_domain :: text, - invited_emails :: text[], trial :: bool + invited_emails :: text[], trial :: bool, updated_at :: timestamptz FROM meetings WHERE end_date < ($1 :: timestamptz) ORDER BY end_date ASC @@ -395,8 +398,8 @@ deleteMeetingBatchImpl meetingIds = do -- Helper functions -rowToMeeting :: (UUID, Text, Text, UUID, Text, UTCTime, UTCTime, Maybe Value, UUID, Text, V.Vector Text, Bool) -> API.Meeting -rowToMeeting (meetingIdUUID, domainText_, titleText, creatorUUID, creatorDomainText, startDate', endDate', recurrenceJSON, convIdUUID, convDomainText, emailsVec, trial') = +rowToMeeting :: (UUID, Text, Text, UUID, Text, UTCTime, UTCTime, Maybe Value, UUID, Text, V.Vector Text, Bool, UTCTime) -> API.Meeting +rowToMeeting (meetingIdUUID, domainText_, titleText, creatorUUID, creatorDomainText, startDate', endDate', recurrenceJSON, convIdUUID, convDomainText, emailsVec, trial', updatedAt') = let meetingId' = Id meetingIdUUID domain' = Domain domainText_ qMeetingId = Qualified meetingId' domain' @@ -420,5 +423,6 @@ rowToMeeting (meetingIdUUID, domainText_, titleText, creatorUUID, creatorDomainT API.recurrence = recurrence', API.conversationId = qConvId, API.invitedEmails = emails', - API.trial = trial' + API.trial = trial', + API.updatedAt = updatedAt' } diff --git a/libs/wire-subsystems/src/Wire/MeetingsSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/MeetingsSubsystem/Interpreter.hs index a70128298f..0fe0c07df5 100644 --- a/libs/wire-subsystems/src/Wire/MeetingsSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/MeetingsSubsystem/Interpreter.hs @@ -20,7 +20,7 @@ module Wire.MeetingsSubsystem.Interpreter where import Data.Id import Data.Qualified import Data.Set qualified as Set -import Data.Time.Clock (UTCTime) +import Data.Time.Clock (UTCTime, getCurrentTime) import Imports import Polysemy import Wire.API.Conversation hiding (Member) @@ -119,6 +119,7 @@ createMeetingImpl zUser newMeeting trial = do newMeeting.invitedEmails trial + now <- liftIO getCurrentTime -- Return created meeting pure ( Meeting @@ -130,7 +131,8 @@ createMeetingImpl zUser newMeeting trial = do recurrence = newMeeting.recurrence, conversationId = qConvId, invitedEmails = newMeeting.invitedEmails, - trial = trial + trial = trial, + updatedAt = now }, storedConv ) diff --git a/services/galley/postgresql-migrations/001_meetings.sql b/services/galley/postgresql-migrations/001_meetings.sql index 740661b530..eceb8e8603 100644 --- a/services/galley/postgresql-migrations/001_meetings.sql +++ b/services/galley/postgresql-migrations/001_meetings.sql @@ -45,6 +45,7 @@ CREATE TABLE IF NOT EXISTS meetings ( -- Timestamps created_at timestamptz NOT NULL DEFAULT NOW(), + updated_at timestamptz NOT NULL DEFAULT NOW(), -- Primary key PRIMARY KEY (domain, id) @@ -100,3 +101,4 @@ COMMENT ON COLUMN meetings.conversation_domain IS 'Domain of the associated conv COMMENT ON COLUMN meetings.invited_emails IS 'Array of email addresses invited to the meeting'; COMMENT ON COLUMN meetings.trial IS 'Whether this meeting is created under a trial account'; COMMENT ON COLUMN meetings.created_at IS 'Timestamp when the meeting was created'; +COMMENT ON COLUMN meetings.updated_at IS 'Timestamp when the meeting was last updated'; From fb85f33d956116c2ab9f7fb4917b6707ce275989 Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Sat, 13 Dec 2025 22:47:16 +0100 Subject: [PATCH 10/29] fix: list test name --- services/galley/test/integration/API/Meetings.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/services/galley/test/integration/API/Meetings.hs b/services/galley/test/integration/API/Meetings.hs index 759badbd66..964cedcfef 100644 --- a/services/galley/test/integration/API/Meetings.hs +++ b/services/galley/test/integration/API/Meetings.hs @@ -45,7 +45,7 @@ tests s = testGroup "Meetings API" [ test s "POST /meetings - create meeting" testMeetingCreate, - test s "GET /meetings - list meetings" testMeetingLists, + test s "GET /meetings/list - list meetings" testMeetingLists, test s "GET /meetings/:domain/:id - get meeting" testMeetingGet, test s "GET /meetings/:domain/:id - meeting not found (404)" testMeetingGetNotFound, test s "PUT /meetings/:domain/:id - update meeting" testMeetingUpdate, From d203bb53dd59324ff676ca2ec1db45c8931093bc Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Sat, 13 Dec 2025 22:52:21 +0100 Subject: [PATCH 11/29] fix: conversation creatio permissions --- libs/wire-subsystems/src/Wire/MeetingsSubsystem/Interpreter.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libs/wire-subsystems/src/Wire/MeetingsSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/MeetingsSubsystem/Interpreter.hs index 0fe0c07df5..c1440b3933 100644 --- a/libs/wire-subsystems/src/Wire/MeetingsSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/MeetingsSubsystem/Interpreter.hs @@ -83,7 +83,7 @@ createMeetingImpl zUser newMeeting trial = do { cnvmType = RegularConv, cnvmCreator = Just (tUnqualified zUser), cnvmAccess = [], - cnvmAccessRoles = Set.empty, + cnvmAccessRoles = Set.fromList [TeamMemberAccessRole, NonTeamMemberAccessRole], cnvmName = Just newMeeting.title, cnvmTeam = Nothing, cnvmMessageTimer = Nothing, From 9f31a22c7c2b4e11feb4146c0bb0791d691927ac Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Sat, 13 Dec 2025 23:26:52 +0100 Subject: [PATCH 12/29] feat: Add recurrence tests and update existing tests to handle recurrence --- .../galley/test/integration/API/Meetings.hs | 100 +++++++++++++++++- 1 file changed, 95 insertions(+), 5 deletions(-) diff --git a/services/galley/test/integration/API/Meetings.hs b/services/galley/test/integration/API/Meetings.hs index 964cedcfef..adc882d707 100644 --- a/services/galley/test/integration/API/Meetings.hs +++ b/services/galley/test/integration/API/Meetings.hs @@ -30,7 +30,7 @@ import Data.Qualified (qDomain, qUnqualified) import Data.Time.Clock import Imports import Test.Tasty -import Test.Tasty.HUnit ((@?=)) +import Test.Tasty.HUnit ((@?=), assertFailure) import TestHelpers import TestSetup import Wire.API.Meeting @@ -45,6 +45,7 @@ tests s = testGroup "Meetings API" [ test s "POST /meetings - create meeting" testMeetingCreate, + test s "POST /meetings - create meeting with recurrence" testMeetingRecurrence, test s "GET /meetings/list - list meetings" testMeetingLists, test s "GET /meetings/:domain/:id - get meeting" testMeetingGet, test s "GET /meetings/:domain/:id - meeting not found (404)" testMeetingGetNotFound, @@ -195,12 +196,20 @@ testMeetingUpdate = do now <- liftIO getCurrentTime let startTime = addUTCTime 3600 now endTime = addUTCTime 7200 now + recurrenceUntil = addUTCTime (60 * 24 * 3600) now -- 60 days from now + initialRecurrence = + object + [ "frequency" .= ("Daily" :: Text), + "interval" .= (1 :: Int), + "until" .= recurrenceUntil + ] newMeeting = object [ "title" .= ("Team Standup" :: Text), "start_date" .= startTime, "end_date" .= endTime, - "invited_emails" .= ([] :: [Text]) + "invited_emails" .= ([] :: [Text]), + "recurrence" .= initialRecurrence ] galley <- viewGalley @@ -217,11 +226,17 @@ testMeetingUpdate = do let meeting = responseJsonUnsafe r1 :: Meeting meetingId = qUnqualified meeting.id domain = qDomain meeting.id + updatedRecurrence = + object + [ "frequency" .= ("Weekly" :: Text), + "interval" .= (2 :: Int) + ] updatedMeeting = object [ "title" .= ("Updated Standup" :: Text), "start_date" .= startTime, - "end_date" .= endTime + "end_date" .= endTime, + "recurrence" .= updatedRecurrence ] r2 <- @@ -235,7 +250,15 @@ testMeetingUpdate = do do + r.freq @?= Weekly + r.interval @?= Just 2 + r.until @?= Nothing -- Should be Nothing as it was not provided in the update + Nothing -> assertFailure "Recurrence should not be Nothing" testMeetingUpdateNotFound :: TestM () testMeetingUpdateNotFound = do @@ -313,12 +336,20 @@ testMeetingDelete = do now <- liftIO getCurrentTime let startTime = addUTCTime 3600 now endTime = addUTCTime 7200 now + recurrenceUntil = addUTCTime (30 * 24 * 3600) now + recurrence = + object + [ "frequency" .= ("Daily" :: Text), + "interval" .= (1 :: Int), + "until" .= recurrenceUntil + ] newMeeting = object [ "title" .= ("Team Standup" :: Text), "start_date" .= startTime, "end_date" .= endTime, - "invited_emails" .= ([] :: [Text]) + "invited_emails" .= ([] :: [Text]), + "recurrence" .= recurrence ] galley <- viewGalley @@ -734,3 +765,62 @@ testMeetingConfigDisabledBlocksList = do . zConn "conn" ) !!! const 403 === statusCode + +testMeetingRecurrence :: TestM () +testMeetingRecurrence = do + (owner, _tid) <- createBindingTeam + now <- liftIO getCurrentTime + let startTime = addUTCTime 3600 now + endTime = addUTCTime 7200 now + recurrenceUntil = addUTCTime (30 * 24 * 3600) now -- 30 days from now + recurrence = + object + [ "frequency" .= ("Daily" :: Text), + "interval" .= (1 :: Int), + "until" .= recurrenceUntil + ] + newMeeting = + object + [ "title" .= ("Daily Standup with Recurrence" :: Text), + "start_date" .= startTime, + "end_date" .= endTime, + "recurrence" .= recurrence, + "invited_emails" .= (["charlie@example.com"] :: [Text]) + ] + + galley <- viewGalley + r1 <- + post + ( galley + . paths ["meetings"] + . zUser owner + . zConn "conn" + . json newMeeting + ) + do + r.freq @?= Daily + r.interval @?= Just 1 + r.until @?= Just recurrenceUntil + Nothing -> assertFailure "Recurrence should not be Nothing" + From eb8449325065e96ed06594c31ca32cc02ccbbee0 Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Sat, 13 Dec 2025 23:30:38 +0100 Subject: [PATCH 13/29] feat: Add date validation tests for meeting creation and updates --- .../galley/test/integration/API/Meetings.hs | 71 +++++++++++++++++++ 1 file changed, 71 insertions(+) diff --git a/services/galley/test/integration/API/Meetings.hs b/services/galley/test/integration/API/Meetings.hs index adc882d707..bac65dfa3c 100644 --- a/services/galley/test/integration/API/Meetings.hs +++ b/services/galley/test/integration/API/Meetings.hs @@ -60,6 +60,8 @@ tests s = test s "POST /meetings/:domain/:id/invitations/:email/delete - remove invitation" testMeetingRemoveInvitation, test s "POST /meetings/:domain/:id/invitations/:email/delete - meeting not found (404)" testMeetingRemoveInvitationNotFound, test s "POST /meetings - personal user creates trial meeting" testMeetingCreatePersonalUserTrial, + test s "POST /meetings - create meeting with invalid dates" testMeetingCreateInvalidDates, + test s "PUT /meetings/:domain/:id - update meeting with invalid dates" testMeetingUpdateInvalidDates, test s "POST /meetings - non-paying team creates trial meeting" testMeetingCreateNonPayingTeamTrial, test s "POST /meetings - paying team creates non-trial meeting" testMeetingCreatePayingTeamNonTrial, test s "POST /meetings - disabled MeetingConfig blocks creation" testMeetingConfigDisabledBlocksCreate, @@ -824,3 +826,72 @@ testMeetingRecurrence = do r.until @?= Just recurrenceUntil Nothing -> assertFailure "Recurrence should not be Nothing" +testMeetingCreateInvalidDates :: TestM () +testMeetingCreateInvalidDates = do + (owner, _tid) <- createBindingTeam + now <- liftIO getCurrentTime + let startTime = addUTCTime 3600 now + endTimeInvalid = addUTCTime 3500 now -- endDate is before startDate + newMeetingInvalid = + object + [ "title" .= ("Invalid Date Meeting" :: Text), + "start_date" .= startTime, + "end_date" .= endTimeInvalid, + "invited_emails" .= ([] :: [Text]) + ] + + galley <- viewGalley + post + ( galley + . paths ["meetings"] + . zUser owner + . zConn "conn" + . json newMeetingInvalid + ) + !!! const 403 === statusCode + +testMeetingUpdateInvalidDates :: TestM () +testMeetingUpdateInvalidDates = do + (owner, _tid) <- createBindingTeam + now <- liftIO getCurrentTime + let startTime = addUTCTime 3600 now + endTime = addUTCTime 7200 now + newMeeting = + object + [ "title" .= ("Valid Meeting" :: Text), + "start_date" .= startTime, + "end_date" .= endTime, + "invited_emails" .= ([] :: [Text]) + ] + + galley <- viewGalley + r1 <- + post + ( galley + . paths ["meetings"] + . zUser owner + . zConn "conn" + . json newMeeting + ) + Date: Sat, 13 Dec 2025 23:37:33 +0100 Subject: [PATCH 14/29] refactor: Move meetings migration to wire-subsystems --- .../postgres-migrations/20251213223355-create-meetings-table.sql | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename services/galley/postgresql-migrations/001_meetings.sql => libs/wire-subsystems/postgres-migrations/20251213223355-create-meetings-table.sql (100%) diff --git a/services/galley/postgresql-migrations/001_meetings.sql b/libs/wire-subsystems/postgres-migrations/20251213223355-create-meetings-table.sql similarity index 100% rename from services/galley/postgresql-migrations/001_meetings.sql rename to libs/wire-subsystems/postgres-migrations/20251213223355-create-meetings-table.sql From 08e1b7c9ae99843f5c7a47c10c94d6b505ab5fb1 Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Mon, 15 Dec 2025 00:39:58 +0100 Subject: [PATCH 15/29] fix(meetings): Correct JSON paths in integration tests The previous implementation of the meetings integration tests used incorrect JSON paths to access fields in the response bodies. This resulted in test failures. This commit corrects the following issues: - Uses 'qualified_id' to access the 'id' and 'domain' of a meeting. - Uses 'qualified_creator' to access the creator's ID. - Corrects the JSON field name for invited emails from 'invitedEmails' to 'invited_emails'. - Fixes the recurrence frequency field name from 'freq' to 'frequency'. - Corrects the extraction of 'teamId' from the 'createTeam' function's return value. --- integration/integration.cabal | 1 + integration/test/Test/Meetings.hs | 574 +++++++++++ integration/test/Testlib/Assertions.hs | 10 + .../galley/test/integration/API/Meetings.hs | 897 ------------------ 4 files changed, 585 insertions(+), 897 deletions(-) create mode 100644 integration/test/Test/Meetings.hs delete mode 100644 services/galley/test/integration/API/Meetings.hs diff --git a/integration/integration.cabal b/integration/integration.cabal index 555ca6a7f1..cc5478dc6a 100644 --- a/integration/integration.cabal +++ b/integration/integration.cabal @@ -173,6 +173,7 @@ library Test.Federator Test.LegalHold Test.Login + Test.Meetings Test.MessageTimer Test.MLS Test.MLS.Clients diff --git a/integration/test/Test/Meetings.hs b/integration/test/Test/Meetings.hs new file mode 100644 index 0000000000..d8fe6e184c --- /dev/null +++ b/integration/test/Test/Meetings.hs @@ -0,0 +1,574 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-ambiguous-fields #-} + +module Test.Meetings where + +import Data.Aeson as Aeson +import Data.Text (Text) +import Data.Time.Clock +import SetupHelpers +import Testlib.Prelude as P + +shouldMatchStatus :: (HasCallStack) => App Response -> Int -> App () +shouldMatchStatus mkResp expectedStatus = do + resp <- mkResp + resp.status `shouldMatchInt` expectedStatus + +-- Custom API helper functions for meetings +postMeetings :: (HasCallStack, MakesValue user) => user -> Aeson.Value -> App Response +postMeetings user newMeeting = do + req <- baseRequest user Galley Versioned "/meetings" + submit "POST" $ req & addJSON newMeeting + +getMeetingsList :: (HasCallStack, MakesValue user) => user -> App Response +getMeetingsList user = do + req <- baseRequest user Galley Versioned "/meetings/list" + submit "GET" req + +getMeeting :: (HasCallStack, MakesValue user) => user -> String -> String -> App Response +getMeeting user domain meetingId = do + req <- baseRequest user Galley Versioned (joinHttpPath ["meetings", domain, meetingId]) + submit "GET" req + +putMeeting :: (HasCallStack, MakesValue user) => user -> String -> String -> Aeson.Value -> App Response +putMeeting user domain meetingId updatedMeeting = do + req <- baseRequest user Galley Versioned (joinHttpPath ["meetings", domain, meetingId]) + submit "PUT" $ req & addJSON updatedMeeting + +deleteMeeting :: (HasCallStack, MakesValue user) => user -> String -> String -> App Response +deleteMeeting user domain meetingId = do + req <- baseRequest user Galley Versioned (joinHttpPath ["meetings", domain, meetingId]) + submit "DELETE" req + +postMeetingInvitation :: (HasCallStack, MakesValue user) => user -> String -> String -> Aeson.Value -> App Response +postMeetingInvitation user domain meetingId invitation = do + req <- baseRequest user Galley Versioned (joinHttpPath ["meetings", domain, meetingId, "invitations"]) + submit "POST" $ req & addJSON invitation + +deleteMeetingInvitation :: (HasCallStack, MakesValue user) => user -> String -> String -> Aeson.Value -> App Response +deleteMeetingInvitation user domain meetingId removeInvitation = do + req <- baseRequest user Galley Versioned (joinHttpPath ["meetings", domain, meetingId, "invitations", "delete"]) + submit "POST" $ req & addJSON removeInvitation + +putTeamFeature :: (HasCallStack, MakesValue user) => user -> String -> String -> Aeson.Value -> App Response +putTeamFeature user tid featureName payload = do + req <- baseRequest user Galley Unversioned (joinHttpPath ["i", "teams", tid, "features", featureName]) + submit "PUT" $ req & addJSON payload + +testMeetingCreate :: (HasCallStack) => App () +testMeetingCreate = do + (owner, _tid, _members) <- createTeam OwnDomain 1 + ownerId <- owner %. "id" >>= asString + now <- liftIO getCurrentTime + let startTime = addUTCTime 3600 now + endTime = addUTCTime 7200 now + newMeeting = + Aeson.object + [ "title" Aeson..= ("Team Standup" :: Text), + "start_date" Aeson..= startTime, + "end_date" Aeson..= endTime, + "invited_emails" Aeson..= (["alice@example.com" :: Text, "bob@example.com"]) + ] + + resp <- postMeetings owner newMeeting + resp.status `shouldMatchInt` 201 + + meeting <- assertOne resp.jsonBody + meeting %. "title" `shouldMatchText` "Team Standup" + meeting %. "qualified_creator" %. "id" `shouldMatch` ownerId + meeting %. "invited_emails" `shouldMatch` ["alice@example.com" :: Text, "bob@example.com"] + +testMeetingLists :: (HasCallStack) => App () +testMeetingLists = do + (owner, _tid, _members) <- createTeam OwnDomain 1 + now <- liftIO getCurrentTime + let startTime = addUTCTime 3600 now + endTime = addUTCTime 7200 now + newMeeting = + Aeson.object + [ "title" Aeson..= ("Team Standup" :: Text), + "start_date" Aeson..= startTime, + "end_date" Aeson..= endTime, + "invited_emails" Aeson..= ([] :: [Text]) + ] + + postMeetings owner newMeeting `shouldMatchStatus` 201 + + resp <- getMeetingsList owner + resp.status `shouldMatchInt` 200 + + meetings <- resp.jsonBody & asList + length (meetings :: [Value]) `shouldMatchInt` 1 + +testMeetingGet :: (HasCallStack) => App () +testMeetingGet = do + (owner, _tid, _members) <- createTeam OwnDomain 1 + now <- liftIO getCurrentTime + let startTime = addUTCTime 3600 now + endTime = addUTCTime 7200 now + newMeeting = + Aeson.object + [ "title" Aeson..= ("Team Standup" :: Text), + "start_date" Aeson..= startTime, + "end_date" Aeson..= endTime, + "invited_emails" Aeson..= ([] :: [Text]) + ] + + r1 <- postMeetings owner newMeeting + r1.status `shouldMatchInt` 201 + + meeting <- assertOne r1.jsonBody + meetingId <- meeting %. "qualified_id" %. "id" >>= asString + domain <- meeting %. "qualified_id" %. "domain" >>= asString + + r2 <- getMeeting owner domain meetingId + r2.status `shouldMatchInt` 200 + + fetchedMeeting <- assertOne r2.jsonBody + fetchedMeeting %. "title" `shouldMatchText` "Team Standup" + +testMeetingGetNotFound :: (HasCallStack) => App () +testMeetingGetNotFound = do + (owner, _tid, _members) <- createTeam OwnDomain 1 + fakeMeetingId <- randomId + + getMeeting owner "example.com" fakeMeetingId `shouldMatchStatus` 404 + +testMeetingUpdate :: (HasCallStack) => App () +testMeetingUpdate = do + (owner, _tid, _members) <- createTeam OwnDomain 1 + now <- liftIO getCurrentTime + let startTime = addUTCTime 3600 now + endTime = addUTCTime 7200 now + recurrenceUntil = addUTCTime (60 * 24 * 3600) now -- 60 days from now + initialRecurrence = + Aeson.object + [ "frequency" Aeson..= ("Daily" :: Text), + "interval" Aeson..= (1 :: Int), + "until" Aeson..= recurrenceUntil + ] + newMeeting = + Aeson.object + [ "title" Aeson..= ("Team Standup" :: Text), + "start_date" Aeson..= startTime, + "end_date" Aeson..= endTime, + "invited_emails" Aeson..= ([] :: [Text]), + "recurrence" Aeson..= initialRecurrence + ] + + r1 <- postMeetings owner newMeeting + r1.status `shouldMatchInt` 201 + + meeting <- assertOne r1.jsonBody + meetingId <- meeting %. "qualified_id" %. "id" >>= asString + domain <- meeting %. "qualified_id" %. "domain" >>= asString + let updatedRecurrence = + Aeson.object + [ "frequency" Aeson..= ("Weekly" :: Text), + "interval" Aeson..= (2 :: Int) + ] + updatedMeeting = + Aeson.object + [ "title" Aeson..= ("Updated Standup" :: Text), + "start_date" Aeson..= startTime, + "end_date" Aeson..= endTime, + "recurrence" Aeson..= updatedRecurrence + ] + + r2 <- putMeeting owner domain meetingId updatedMeeting + r2.status `shouldMatchInt` 200 + + updated <- assertOne r2.jsonBody + updated %. "title" `shouldMatchText` "Updated Standup" + recurrence <- updated %. "recurrence" + recurrence %. "frequency" `shouldMatchText` "Weekly" + recurrence %. "interval" `shouldMatchInt` 2 + +testMeetingUpdateNotFound :: (HasCallStack) => App () +testMeetingUpdateNotFound = do + (owner, _tid, _members) <- createTeam OwnDomain 1 + fakeMeetingId <- randomId + now <- liftIO getCurrentTime + let startTime = addUTCTime 3600 now + endTime = addUTCTime 7200 now + update = + Aeson.object + [ "title" Aeson..= ("Updated" :: Text), + "start_date" Aeson..= startTime, + "end_date" Aeson..= endTime + ] + + putMeeting owner "example.com" fakeMeetingId update `shouldMatchStatus` 404 + +testMeetingUpdateUnauthorized :: (HasCallStack) => App () +testMeetingUpdateUnauthorized = do + (owner, _tid, _members) <- createTeam OwnDomain 1 + (otherUser, _, _membersOther) <- createTeam OwnDomain 1 + now <- liftIO getCurrentTime + let startTime = addUTCTime 3600 now + endTime = addUTCTime 7200 now + newMeeting = + Aeson.object + [ "title" Aeson..= ("Team Standup" :: Text), + "start_date" Aeson..= startTime, + "end_date" Aeson..= endTime, + "invited_emails" Aeson..= ([] :: [Text]) + ] + + r1 <- postMeetings owner newMeeting + r1.status `shouldMatchInt` 201 + + meeting <- assertOne r1.jsonBody + meetingId <- meeting %. "qualified_id" %. "id" >>= asString + domain <- meeting %. "qualified_id" %. "domain" >>= asString + let update = + Aeson.object + [ "title" Aeson..= ("Hijacked" :: Text), + "start_date" Aeson..= startTime, + "end_date" Aeson..= endTime + ] + + putMeeting otherUser domain meetingId update `shouldMatchStatus` 404 + +testMeetingDelete :: (HasCallStack) => App () +testMeetingDelete = do + (owner, _tid, _members) <- createTeam OwnDomain 1 + now <- liftIO getCurrentTime + let startTime = addUTCTime 3600 now + endTime = addUTCTime 7200 now + recurrenceUntil = addUTCTime (30 * 24 * 3600) now + recurrence = + Aeson.object + [ "frequency" Aeson..= ("Daily" :: Text), + "interval" Aeson..= (1 :: Int), + "until" Aeson..= recurrenceUntil + ] + newMeeting = + Aeson.object + [ "title" Aeson..= ("Team Standup" :: Text), + "start_date" Aeson..= startTime, + "end_date" Aeson..= endTime, + "invited_emails" Aeson..= ([] :: [Text]), + "recurrence" Aeson..= recurrence + ] + + r1 <- postMeetings owner newMeeting + r1.status `shouldMatchInt` 201 + + meeting <- assertOne r1.jsonBody + meetingId <- meeting %. "qualified_id" %. "id" >>= asString + domain <- meeting %. "qualified_id" %. "domain" >>= asString + + deleteMeeting owner domain meetingId `shouldMatchStatus` 200 + + getMeeting owner domain meetingId `shouldMatchStatus` 404 + +testMeetingDeleteNotFound :: (HasCallStack) => App () +testMeetingDeleteNotFound = do + (owner, _tid, _members) <- createTeam OwnDomain 1 + fakeMeetingId <- randomId + + deleteMeeting owner "example.com" fakeMeetingId `shouldMatchStatus` 404 + +testMeetingDeleteUnauthorized :: (HasCallStack) => App () +testMeetingDeleteUnauthorized = do + (owner, _tid, _members) <- createTeam OwnDomain 1 + (otherUser, _, _membersOther) <- createTeam OwnDomain 1 + now <- liftIO getCurrentTime + let startTime = addUTCTime 3600 now + endTime = addUTCTime 7200 now + newMeeting = + Aeson.object + [ "title" Aeson..= ("Team Standup" :: Text), + "start_date" Aeson..= startTime, + "end_date" Aeson..= endTime, + "invited_emails" Aeson..= ([] :: [Text]) + ] + + r1 <- postMeetings owner newMeeting + r1.status `shouldMatchInt` 201 + + meeting <- assertOne r1.jsonBody + meetingId <- meeting %. "qualified_id" %. "id" >>= asString + domain <- meeting %. "qualified_id" %. "domain" >>= asString + + deleteMeeting otherUser domain meetingId `shouldMatchStatus` 404 + +testMeetingAddInvitation :: (HasCallStack) => App () +testMeetingAddInvitation = do + (owner, _tid, _members) <- createTeam OwnDomain 1 + now <- liftIO getCurrentTime + let startTime = addUTCTime 3600 now + endTime = addUTCTime 7200 now + newMeeting = + Aeson.object + [ "title" Aeson..= ("Team Standup" :: Text), + "start_date" Aeson..= startTime, + "end_date" Aeson..= endTime, + "invited_emails" Aeson..= (["alice@example.com"] :: [Text]) + ] + + r1 <- postMeetings owner newMeeting + r1.status `shouldMatchInt` 201 + + meeting <- assertOne r1.jsonBody + meetingId <- meeting %. "qualified_id" %. "id" >>= asString + domain <- meeting %. "qualified_id" %. "domain" >>= asString + let invitation = Aeson.object ["emails" Aeson..= ["bob@example.com" :: Text]] + + postMeetingInvitation owner domain meetingId invitation `shouldMatchStatus` 200 + + r2 <- getMeeting owner domain meetingId + r2.status `shouldMatchInt` 200 + + updated <- assertOne r2.jsonBody + updated %. "invited_emails" `shouldMatch` ["alice@example.com" :: Text, "bob@example.com"] + +testMeetingAddInvitationNotFound :: (HasCallStack) => App () +testMeetingAddInvitationNotFound = do + (owner, _tid, _members) <- createTeam OwnDomain 1 + fakeMeetingId <- randomId + let invitation = Aeson.object ["emails" Aeson..= ["bob@example.com" :: Text]] + + postMeetingInvitation owner "example.com" fakeMeetingId invitation `shouldMatchStatus` 404 + +testMeetingRemoveInvitation :: (HasCallStack) => App () +testMeetingRemoveInvitation = do + (owner, _tid, _members) <- createTeam OwnDomain 1 + now <- liftIO getCurrentTime + let startTime = addUTCTime 3600 now + endTime = addUTCTime 7200 now + newMeeting = + Aeson.object + [ "title" Aeson..= ("Team Standup" :: Text), + "start_date" Aeson..= startTime, + "end_date" Aeson..= endTime, + "invited_emails" Aeson..= (["alice@example.com", "bob@example.com"] :: [Text]) + ] + + r1 <- postMeetings owner newMeeting + r1.status `shouldMatchInt` 201 + + meeting <- assertOne r1.jsonBody + meetingId <- meeting %. "qualified_id" %. "id" >>= asString + domain <- meeting %. "qualified_id" %. "domain" >>= asString + let removeInvitation = Aeson.object ["emails" Aeson..= ["alice@example.com" :: Text]] + + deleteMeetingInvitation owner domain meetingId removeInvitation `shouldMatchStatus` 200 + + r2 <- getMeeting owner domain meetingId + r2.status `shouldMatchInt` 200 + + updated <- assertOne r2.jsonBody + updated %. "invited_emails" `shouldMatch` ["bob@example.com" :: Text] + +testMeetingRemoveInvitationNotFound :: (HasCallStack) => App () +testMeetingRemoveInvitationNotFound = do + (owner, _tid, _members) <- createTeam OwnDomain 1 + fakeMeetingId <- randomId + let removeInvitation = Aeson.object ["emails" Aeson..= ["alice@example.com" :: Text]] + + deleteMeetingInvitation owner "example.com" fakeMeetingId removeInvitation `shouldMatchStatus` 404 + +-- Test that personal (non-team) users create trial meetings +testMeetingCreatePersonalUserTrial :: (HasCallStack) => App () +testMeetingCreatePersonalUserTrial = do + personalUser <- randomUser OwnDomain def + now <- liftIO getCurrentTime + let startTime = addUTCTime 3600 now + endTime = addUTCTime 7200 now + newMeeting = + Aeson.object + [ "title" Aeson..= ("Personal Meeting" :: Text), + "start_date" Aeson..= startTime, + "end_date" Aeson..= endTime, + "invited_emails" Aeson..= ([] :: [Text]) + ] + + r <- postMeetings personalUser newMeeting + r.status `shouldMatchInt` 201 + + meeting <- assertOne r.jsonBody + meeting %. "trial" `shouldMatch` True + +-- Test that non-paying team members create trial meetings +testMeetingCreateNonPayingTeamTrial :: (HasCallStack) => App () +testMeetingCreateNonPayingTeamTrial = do + (owner, tid, _members) <- createTeam OwnDomain 1 + + let teamId = tid + putTeamFeature owner teamId "meetingPremium" (Aeson.object ["status" Aeson..= ("disabled" :: Text)]) `shouldMatchStatus` 200 + + now <- liftIO getCurrentTime + let startTime = addUTCTime 3600 now + endTime = addUTCTime 7200 now + newMeeting = + Aeson.object + [ "title" Aeson..= ("Non-Paying Team Meeting" :: Text), + "start_date" Aeson..= startTime, + "end_date" Aeson..= endTime, + "invited_emails" Aeson..= ([] :: [Text]) + ] + + r <- postMeetings owner newMeeting + r.status `shouldMatchInt` 201 + + meeting <- assertOne r.jsonBody + meeting %. "trial" `shouldMatch` True + +-- Test that paying team members create non-trial meetings +testMeetingCreatePayingTeamNonTrial :: (HasCallStack) => App () +testMeetingCreatePayingTeamNonTrial = do + (owner, tid, _members) <- createTeam OwnDomain 1 + + let teamId = tid + putTeamFeature owner teamId "meetingPremium" (Aeson.object ["status" Aeson..= ("enabled" :: Text)]) `shouldMatchStatus` 200 + + now <- liftIO getCurrentTime + let startTime = addUTCTime 3600 now + endTime = addUTCTime 7200 now + newMeeting = + Aeson.object + [ "title" Aeson..= ("Paying Team Meeting" :: Text), + "start_date" Aeson..= startTime, + "end_date" Aeson..= endTime, + "invited_emails" Aeson..= ([] :: [Text]) + ] + + r <- postMeetings owner newMeeting + r.status `shouldMatchInt` 201 + + meeting <- assertOne r.jsonBody + meeting %. "trial" `shouldMatch` False + +-- Test that disabled MeetingConfig feature blocks creation +testMeetingConfigDisabledBlocksCreate :: (HasCallStack) => App () +testMeetingConfigDisabledBlocksCreate = do + (owner, tid, _members) <- createTeam OwnDomain 1 + + -- Disable the MeetingConfig feature + let teamId = tid + putTeamFeature owner teamId "meeting" (Aeson.object ["status" Aeson..= ("disabled" :: Text), "lockStatus" Aeson..= ("unlocked" :: Text)]) `shouldMatchStatus` 200 + + -- Try to create a meeting - should fail + now <- liftIO getCurrentTime + let startTime = addUTCTime 3600 now + endTime = addUTCTime 7200 now + newMeeting = + Aeson.object + [ "title" Aeson..= ("Team Standup" :: Text), + "start_date" Aeson..= startTime, + "end_date" Aeson..= endTime + ] + + postMeetings owner newMeeting `shouldMatchStatus` 403 + +-- Test that disabled MeetingConfig feature blocks meeting listing +testMeetingConfigDisabledBlocksList :: (HasCallStack) => App () +testMeetingConfigDisabledBlocksList = do + (owner, tid, _members) <- createTeam OwnDomain 1 + + -- First create a meeting while feature is enabled + now <- liftIO getCurrentTime + let startTime = addUTCTime 3600 now + endTime = addUTCTime 7200 now + newMeeting = + Aeson.object + [ "title" Aeson..= ("Team Standup" :: Text), + "start_date" Aeson..= startTime, + "end_date" Aeson..= endTime + ] + + postMeetings owner newMeeting `shouldMatchStatus` 201 + + -- Disable the MeetingConfig feature + let teamId = tid + putTeamFeature owner teamId "meeting" (Aeson.object ["status" Aeson..= ("disabled" :: Text), "lockStatus" Aeson..= ("unlocked" :: Text)]) `shouldMatchStatus` 200 + + -- Try to list meetings - should fail + getMeetingsList owner `shouldMatchStatus` 403 + +testMeetingRecurrence :: (HasCallStack) => App () +testMeetingRecurrence = do + (owner, _tid, _members) <- createTeam OwnDomain 1 + now <- liftIO getCurrentTime + let startTime = addUTCTime 3600 now + endTime = addUTCTime 7200 now + recurrenceUntil = addUTCTime (30 * 24 * 3600) now -- 30 days from now + recurrence = + Aeson.object + [ "frequency" Aeson..= ("Daily" :: Text), + "interval" Aeson..= (1 :: Int), + "until" Aeson..= recurrenceUntil + ] + newMeeting = + Aeson.object + [ "title" Aeson..= ("Daily Standup with Recurrence" :: Text), + "start_date" Aeson..= startTime, + "end_date" Aeson..= endTime, + "recurrence" Aeson..= recurrence, + "invited_emails" Aeson..= (["charlie@example.com"] :: [Text]) + ] + + r1 <- postMeetings owner newMeeting + r1.status `shouldMatchInt` 201 + + meeting <- assertOne r1.jsonBody + meetingId <- meeting %. "qualified_id" %. "id" >>= asString + domain <- meeting %. "qualified_id" %. "domain" >>= asString + + r2 <- getMeeting owner domain meetingId + r2.status `shouldMatchInt` 200 + + fetchedMeeting <- assertOne r2.jsonBody + fetchedMeeting %. "title" `shouldMatchText` "Daily Standup with Recurrence" + recurrence' <- fetchedMeeting %. "recurrence" + recurrence' %. "frequency" `shouldMatchText` "Daily" + recurrence' %. "interval" `shouldMatchInt` 1 + recurrence' %. "until" `shouldMatch` recurrenceUntil + +testMeetingCreateInvalidDates :: (HasCallStack) => App () +testMeetingCreateInvalidDates = do + (owner, _tid, _members) <- createTeam OwnDomain 1 + now <- liftIO getCurrentTime + let startTime = addUTCTime 3600 now + endTimeInvalid = addUTCTime 3500 now -- endDate is before startDate + newMeetingInvalid = + Aeson.object + [ "title" Aeson..= ("Invalid Date" :: Text), + "start_date" Aeson..= startTime, + "end_date" Aeson..= endTimeInvalid, + "invited_emails" Aeson..= ([] :: [Text]) + ] + + postMeetings owner newMeetingInvalid `shouldMatchStatus` 403 + +testMeetingUpdateInvalidDates :: (HasCallStack) => App () +testMeetingUpdateInvalidDates = do + (owner, _tid, _members) <- createTeam OwnDomain 1 + now <- liftIO getCurrentTime + let startTime = addUTCTime 3600 now + endTime = addUTCTime 7200 now + newMeeting = + Aeson.object + [ "title" Aeson..= ("Valid Meeting" :: Text), + "start_date" Aeson..= startTime, + "end_date" Aeson..= endTime, + "invited_emails" Aeson..= ([] :: [Text]) + ] + + r1 <- postMeetings owner newMeeting + r1.status `shouldMatchInt` 201 + + meeting <- assertOne r1.jsonBody + meetingId <- meeting %. "qualified_id" %. "id" >>= asString + domain <- meeting %. "qualified_id" %. "domain" >>= asString + let updatedStartTime = addUTCTime 1800 now + updatedEndTimeInvalid = addUTCTime 1000 now -- endDate is before startDate + updatedMeeting = + Aeson.object + [ "start_date" Aeson..= updatedStartTime, + "end_date" Aeson..= updatedEndTimeInvalid + ] + + putMeeting owner domain meetingId updatedMeeting `shouldMatchStatus` 403 diff --git a/integration/test/Testlib/Assertions.hs b/integration/test/Testlib/Assertions.hs index 1f620927ca..31b9c23a4f 100644 --- a/integration/test/Testlib/Assertions.hs +++ b/integration/test/Testlib/Assertions.hs @@ -224,6 +224,16 @@ shouldNotMatchInt :: App () shouldNotMatchInt = shouldNotMatch +-- | Specialized variant of `shouldMatch` to avoid the need for type annotations. +shouldMatchText :: + (MakesValue a, HasCallStack) => + -- | The actual value + a -> + -- | The expected value + Text.Text -> + App () +shouldMatchText = shouldMatch + shouldMatchRange :: (MakesValue a, HasCallStack) => -- | The actual value diff --git a/services/galley/test/integration/API/Meetings.hs b/services/galley/test/integration/API/Meetings.hs deleted file mode 100644 index bac65dfa3c..0000000000 --- a/services/galley/test/integration/API/Meetings.hs +++ /dev/null @@ -1,897 +0,0 @@ --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2025 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 API.Meetings - ( tests, - ) -where - -import API.Util -import Bilge hiding (timeout) -import Bilge.Assert -import Data.Aeson -import Data.ByteString.Conversion (toByteString') -import Data.Id (MeetingId, idToText, randomId) -import Data.Qualified (qDomain, qUnqualified) -import Data.Time.Clock -import Imports -import Test.Tasty -import Test.Tasty.HUnit ((@?=), assertFailure) -import TestHelpers -import TestSetup -import Wire.API.Meeting -import Wire.API.User.Identity (emailAddressText) - --- Helper to convert MeetingId to ByteString for URL paths -meetingIdToBS :: MeetingId -> ByteString -meetingIdToBS = toByteString' . idToText - -tests :: IO TestSetup -> TestTree -tests s = - testGroup - "Meetings API" - [ test s "POST /meetings - create meeting" testMeetingCreate, - test s "POST /meetings - create meeting with recurrence" testMeetingRecurrence, - test s "GET /meetings/list - list meetings" testMeetingLists, - test s "GET /meetings/:domain/:id - get meeting" testMeetingGet, - test s "GET /meetings/:domain/:id - meeting not found (404)" testMeetingGetNotFound, - test s "PUT /meetings/:domain/:id - update meeting" testMeetingUpdate, - test s "PUT /meetings/:domain/:id - update meeting not found (404)" testMeetingUpdateNotFound, - test s "PUT /meetings/:domain/:id - update meeting unauthorized (404)" testMeetingUpdateUnauthorized, - test s "DELETE /meetings/:domain/:id - delete meeting" testMeetingDelete, - test s "DELETE /meetings/:domain/:id - delete meeting not found (404)" testMeetingDeleteNotFound, - test s "DELETE /meetings/:domain/:id - delete meeting unauthorized (404)" testMeetingDeleteUnauthorized, - test s "POST /meetings/:domain/:id/invitations - add invitation" testMeetingAddInvitation, - test s "POST /meetings/:domain/:id/invitations - meeting not found (404)" testMeetingAddInvitationNotFound, - test s "POST /meetings/:domain/:id/invitations/:email/delete - remove invitation" testMeetingRemoveInvitation, - test s "POST /meetings/:domain/:id/invitations/:email/delete - meeting not found (404)" testMeetingRemoveInvitationNotFound, - test s "POST /meetings - personal user creates trial meeting" testMeetingCreatePersonalUserTrial, - test s "POST /meetings - create meeting with invalid dates" testMeetingCreateInvalidDates, - test s "PUT /meetings/:domain/:id - update meeting with invalid dates" testMeetingUpdateInvalidDates, - test s "POST /meetings - non-paying team creates trial meeting" testMeetingCreateNonPayingTeamTrial, - test s "POST /meetings - paying team creates non-trial meeting" testMeetingCreatePayingTeamNonTrial, - test s "POST /meetings - disabled MeetingConfig blocks creation" testMeetingConfigDisabledBlocksCreate, - test s "GET /meetings - disabled MeetingConfig blocks listing" testMeetingConfigDisabledBlocksList - ] - -testMeetingCreate :: TestM () -testMeetingCreate = do - (owner, _tid) <- createBindingTeam - now <- liftIO getCurrentTime - let startTime = addUTCTime 3600 now - endTime = addUTCTime 7200 now - newMeeting = - object - [ "title" .= ("Team Standup" :: Text), - "start_date" .= startTime, - "end_date" .= endTime, - "invited_emails" .= (["alice@example.com", "bob@example.com"] :: [Text]) - ] - - galley <- viewGalley - r <- - post - ( galley - . paths ["meetings"] - . zUser owner - . zConn "conn" - . json newMeeting - ) - do - r.freq @?= Weekly - r.interval @?= Just 2 - r.until @?= Nothing -- Should be Nothing as it was not provided in the update - Nothing -> assertFailure "Recurrence should not be Nothing" - -testMeetingUpdateNotFound :: TestM () -testMeetingUpdateNotFound = do - (owner, _tid) <- createBindingTeam - fakeMeetingId <- randomId - localDomain <- viewFederationDomain - now <- liftIO getCurrentTime - let startTime = addUTCTime 3600 now - endTime = addUTCTime 7200 now - update = - object - [ "title" .= ("Updated" :: Text), - "start_date" .= startTime, - "end_date" .= endTime - ] - - galley <- viewGalley - put - ( galley - . paths ["meetings", toByteString' localDomain, meetingIdToBS fakeMeetingId] - . zUser owner - . zConn "conn" - . json update - ) - !!! const 404 === statusCode - -testMeetingUpdateUnauthorized :: TestM () -testMeetingUpdateUnauthorized = do - (owner, _tid) <- createBindingTeam - (otherUser, _) <- createBindingTeam - now <- liftIO getCurrentTime - let startTime = addUTCTime 3600 now - endTime = addUTCTime 7200 now - newMeeting = - object - [ "title" .= ("Team Standup" :: Text), - "start_date" .= startTime, - "end_date" .= endTime, - "invited_emails" .= ([] :: [Text]) - ] - - galley <- viewGalley - r1 <- - post - ( galley - . paths ["meetings"] - . zUser owner - . zConn "conn" - . json newMeeting - ) - do - r.freq @?= Daily - r.interval @?= Just 1 - r.until @?= Just recurrenceUntil - Nothing -> assertFailure "Recurrence should not be Nothing" - -testMeetingCreateInvalidDates :: TestM () -testMeetingCreateInvalidDates = do - (owner, _tid) <- createBindingTeam - now <- liftIO getCurrentTime - let startTime = addUTCTime 3600 now - endTimeInvalid = addUTCTime 3500 now -- endDate is before startDate - newMeetingInvalid = - object - [ "title" .= ("Invalid Date Meeting" :: Text), - "start_date" .= startTime, - "end_date" .= endTimeInvalid, - "invited_emails" .= ([] :: [Text]) - ] - - galley <- viewGalley - post - ( galley - . paths ["meetings"] - . zUser owner - . zConn "conn" - . json newMeetingInvalid - ) - !!! const 403 === statusCode - -testMeetingUpdateInvalidDates :: TestM () -testMeetingUpdateInvalidDates = do - (owner, _tid) <- createBindingTeam - now <- liftIO getCurrentTime - let startTime = addUTCTime 3600 now - endTime = addUTCTime 7200 now - newMeeting = - object - [ "title" .= ("Valid Meeting" :: Text), - "start_date" .= startTime, - "end_date" .= endTime, - "invited_emails" .= ([] :: [Text]) - ] - - galley <- viewGalley - r1 <- - post - ( galley - . paths ["meetings"] - . zUser owner - . zConn "conn" - . json newMeeting - ) - Date: Mon, 15 Dec 2025 01:00:10 +0100 Subject: [PATCH 16/29] feat(meetings): Use lowercase for frequency serialization This commit updates the 'Frequency' enum to serialize to and from lowercase strings (e.g., "daily", "weekly"). - The instance now uses to convert the constructor names to lowercase. - The instance is updated to handle both uppercase and lowercase values for backward compatibility. - The instance is updated to reflect the new lowercase values. - The integration tests are updated to use and expect lowercase frequency values. --- integration/test/Test/Meetings.hs | 12 ++++++------ libs/wire-api/src/Wire/API/Meeting.hs | 21 ++++++++++----------- services/galley/galley.cabal | 1 - services/galley/test/integration/API.hs | 2 -- 4 files changed, 16 insertions(+), 20 deletions(-) diff --git a/integration/test/Test/Meetings.hs b/integration/test/Test/Meetings.hs index d8fe6e184c..ec6be280d1 100644 --- a/integration/test/Test/Meetings.hs +++ b/integration/test/Test/Meetings.hs @@ -143,7 +143,7 @@ testMeetingUpdate = do recurrenceUntil = addUTCTime (60 * 24 * 3600) now -- 60 days from now initialRecurrence = Aeson.object - [ "frequency" Aeson..= ("Daily" :: Text), + [ "frequency" Aeson..= ("daily" :: Text), "interval" Aeson..= (1 :: Int), "until" Aeson..= recurrenceUntil ] @@ -164,7 +164,7 @@ testMeetingUpdate = do domain <- meeting %. "qualified_id" %. "domain" >>= asString let updatedRecurrence = Aeson.object - [ "frequency" Aeson..= ("Weekly" :: Text), + [ "frequency" Aeson..= ("weekly" :: Text), "interval" Aeson..= (2 :: Int) ] updatedMeeting = @@ -181,7 +181,7 @@ testMeetingUpdate = do updated <- assertOne r2.jsonBody updated %. "title" `shouldMatchText` "Updated Standup" recurrence <- updated %. "recurrence" - recurrence %. "frequency" `shouldMatchText` "Weekly" + recurrence %. "frequency" `shouldMatchText` "weekly" recurrence %. "interval" `shouldMatchInt` 2 testMeetingUpdateNotFound :: (HasCallStack) => App () @@ -239,7 +239,7 @@ testMeetingDelete = do recurrenceUntil = addUTCTime (30 * 24 * 3600) now recurrence = Aeson.object - [ "frequency" Aeson..= ("Daily" :: Text), + [ "frequency" Aeson..= ("daily" :: Text), "interval" Aeson..= (1 :: Int), "until" Aeson..= recurrenceUntil ] @@ -497,7 +497,7 @@ testMeetingRecurrence = do recurrenceUntil = addUTCTime (30 * 24 * 3600) now -- 30 days from now recurrence = Aeson.object - [ "frequency" Aeson..= ("Daily" :: Text), + [ "frequency" Aeson..= ("daily" :: Text), "interval" Aeson..= (1 :: Int), "until" Aeson..= recurrenceUntil ] @@ -523,7 +523,7 @@ testMeetingRecurrence = do fetchedMeeting <- assertOne r2.jsonBody fetchedMeeting %. "title" `shouldMatchText` "Daily Standup with Recurrence" recurrence' <- fetchedMeeting %. "recurrence" - recurrence' %. "frequency" `shouldMatchText` "Daily" + recurrence' %. "frequency" `shouldMatchText` "daily" recurrence' %. "interval" `shouldMatchInt` 1 recurrence' %. "until" `shouldMatch` recurrenceUntil diff --git a/libs/wire-api/src/Wire/API/Meeting.hs b/libs/wire-api/src/Wire/API/Meeting.hs index 64194ff5f4..e600374231 100644 --- a/libs/wire-api/src/Wire/API/Meeting.hs +++ b/libs/wire-api/src/Wire/API/Meeting.hs @@ -18,7 +18,6 @@ module Wire.API.Meeting where import Control.Lens ((?~)) -import Data.Aeson () import Data.Id (ConvId, MeetingId, UserId) import Data.Json.Util (utcTimeSchema) import Data.OpenApi qualified as S @@ -89,6 +88,16 @@ data Frequency = Daily | Weekly | Monthly | Yearly deriving (ToJSON, FromJSON, S.ToSchema) via (Schema Frequency) deriving (Arbitrary) via (GenericUniform Frequency) +instance ToSchema Frequency where + schema = + enum @Text "Frequency" $ + mconcat + [ element "daily" Daily, + element "weekly" Weekly, + element "monthly" Monthly, + element "yearly" Yearly + ] + instance ToSchema NewMeeting where schema = objectWithDocModifier "NewMeeting" (description ?~ "Request to create a new meeting") $ @@ -119,16 +128,6 @@ instance ToSchema UpdateMeeting where <*> (.title) .= maybe_ (optField "title" schema) <*> (.recurrence) .= maybe_ (optField "recurrence" schema) -instance ToSchema Frequency where - schema = - enum @Text "Frequency" $ - mconcat - [ element "Daily" Daily, - element "Weekly" Weekly, - element "Monthly" Monthly, - element "Yearly" Yearly - ] - instance ToSchema Recurrence where schema = objectWithDocModifier "Recurrence" (description ?~ "Recurrence pattern for meetings") $ diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index e7e1df4cff..e0a9f5154b 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -365,7 +365,6 @@ executable galley-integration API.CustomBackend API.Federation API.Federation.Util - API.Meetings API.MessageTimer API.MLS API.MLS.Mocks diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index ce0a4fd272..e0f65f5d3a 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -28,7 +28,6 @@ where import API.CustomBackend qualified as CustomBackend import API.Federation qualified as Federation import API.MLS qualified -import API.Meetings qualified as Meetings import API.MessageTimer qualified as MessageTimer import API.Roles qualified as Roles import API.SQS @@ -119,7 +118,6 @@ tests s = MessageTimer.tests s, Roles.tests s, CustomBackend.tests s, - Meetings.tests s, Federation.tests s, API.MLS.tests s ] From 5d81620f97d28e5a564261c196138f0092c1f2c7 Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Mon, 15 Dec 2025 01:29:15 +0100 Subject: [PATCH 17/29] refactor: apply suggestions in libs/wire-subsystems/src/Wire/MeetingsStore/Postgres.hs --- .../src/Wire/MeetingsStore/Postgres.hs | 11 +++-------- 1 file changed, 3 insertions(+), 8 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/MeetingsStore/Postgres.hs b/libs/wire-subsystems/src/Wire/MeetingsStore/Postgres.hs index 2460516a9c..91516a7b68 100644 --- a/libs/wire-subsystems/src/Wire/MeetingsStore/Postgres.hs +++ b/libs/wire-subsystems/src/Wire/MeetingsStore/Postgres.hs @@ -382,18 +382,13 @@ deleteMeetingBatchImpl meetingIds = do either throw pure result where session :: Session Int64 - session = foldM deleteSingle 0 meetingIds + session = statement (V.fromList (toUUID . qUnqualified <$> meetingIds), V.fromList (_domainText . qDomain <$> meetingIds)) deleteStatement - deleteSingle :: Int64 -> Qualified MeetingId -> Session Int64 - deleteSingle acc qMeetingId = do - count <- statement (idToText (qUnqualified qMeetingId), _domainText (qDomain qMeetingId)) deleteStatement - pure (acc + count) - - deleteStatement :: Statement (Text, Text) Int64 + deleteStatement :: Statement (V.Vector UUID, V.Vector Text) Int64 deleteStatement = [rowsAffectedStatement| DELETE FROM meetings - WHERE id :: text = ($1 :: text) AND domain = ($2 :: text) + WHERE (id, domain) IN (SELECT * FROM unnest($1::uuid[], $2::text[])) |] -- Helper functions From 44faf701ae45ad314d76cf5b49a30a725bb5953c Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Mon, 15 Dec 2025 01:58:08 +0100 Subject: [PATCH 18/29] refactor: clean integration test --- integration/test/Test/Meetings.hs | 168 +++++++++--------------------- 1 file changed, 47 insertions(+), 121 deletions(-) diff --git a/integration/test/Test/Meetings.hs b/integration/test/Test/Meetings.hs index ec6be280d1..ef4f4537df 100644 --- a/integration/test/Test/Meetings.hs +++ b/integration/test/Test/Meetings.hs @@ -55,6 +55,23 @@ putTeamFeature user tid featureName payload = do req <- baseRequest user Galley Unversioned (joinHttpPath ["i", "teams", tid, "features", featureName]) submit "PUT" $ req & addJSON payload +-- Helper to create a default new meeting JSON object +defaultMeetingJson :: Text -> UTCTime -> UTCTime -> [Text] -> Aeson.Value +defaultMeetingJson title startTime endTime invitedEmails = + Aeson.object + [ "title" Aeson..= title, + "start_date" Aeson..= startTime, + "end_date" Aeson..= endTime, + "invited_emails" Aeson..= invitedEmails + ] + +-- Helper to extract meetingId and domain from a meeting JSON object +getMeetingIdAndDomain :: (HasCallStack) => Aeson.Value -> App (String, String) +getMeetingIdAndDomain meeting = do + meetingId <- meeting %. "qualified_id" %. "id" >>= asString + domain <- meeting %. "qualified_id" %. "domain" >>= asString + return (meetingId, domain) + testMeetingCreate :: (HasCallStack) => App () testMeetingCreate = do (owner, _tid, _members) <- createTeam OwnDomain 1 @@ -62,13 +79,7 @@ testMeetingCreate = do now <- liftIO getCurrentTime let startTime = addUTCTime 3600 now endTime = addUTCTime 7200 now - newMeeting = - Aeson.object - [ "title" Aeson..= ("Team Standup" :: Text), - "start_date" Aeson..= startTime, - "end_date" Aeson..= endTime, - "invited_emails" Aeson..= (["alice@example.com" :: Text, "bob@example.com"]) - ] + newMeeting = defaultMeetingJson "Team Standup" startTime endTime ["alice@example.com", "bob@example.com"] resp <- postMeetings owner newMeeting resp.status `shouldMatchInt` 201 @@ -84,13 +95,7 @@ testMeetingLists = do now <- liftIO getCurrentTime let startTime = addUTCTime 3600 now endTime = addUTCTime 7200 now - newMeeting = - Aeson.object - [ "title" Aeson..= ("Team Standup" :: Text), - "start_date" Aeson..= startTime, - "end_date" Aeson..= endTime, - "invited_emails" Aeson..= ([] :: [Text]) - ] + newMeeting = defaultMeetingJson "Team Standup" startTime endTime [] postMeetings owner newMeeting `shouldMatchStatus` 201 @@ -106,20 +111,13 @@ testMeetingGet = do now <- liftIO getCurrentTime let startTime = addUTCTime 3600 now endTime = addUTCTime 7200 now - newMeeting = - Aeson.object - [ "title" Aeson..= ("Team Standup" :: Text), - "start_date" Aeson..= startTime, - "end_date" Aeson..= endTime, - "invited_emails" Aeson..= ([] :: [Text]) - ] + newMeeting = defaultMeetingJson "Team Standup" startTime endTime [] r1 <- postMeetings owner newMeeting r1.status `shouldMatchInt` 201 meeting <- assertOne r1.jsonBody - meetingId <- meeting %. "qualified_id" %. "id" >>= asString - domain <- meeting %. "qualified_id" %. "domain" >>= asString + (meetingId, domain) <- getMeetingIdAndDomain meeting r2 <- getMeeting owner domain meetingId r2.status `shouldMatchInt` 200 @@ -160,8 +158,7 @@ testMeetingUpdate = do r1.status `shouldMatchInt` 201 meeting <- assertOne r1.jsonBody - meetingId <- meeting %. "qualified_id" %. "id" >>= asString - domain <- meeting %. "qualified_id" %. "domain" >>= asString + (meetingId, domain) <- getMeetingIdAndDomain meeting let updatedRecurrence = Aeson.object [ "frequency" Aeson..= ("weekly" :: Text), @@ -207,20 +204,13 @@ testMeetingUpdateUnauthorized = do now <- liftIO getCurrentTime let startTime = addUTCTime 3600 now endTime = addUTCTime 7200 now - newMeeting = - Aeson.object - [ "title" Aeson..= ("Team Standup" :: Text), - "start_date" Aeson..= startTime, - "end_date" Aeson..= endTime, - "invited_emails" Aeson..= ([] :: [Text]) - ] + newMeeting = defaultMeetingJson "Team Standup" startTime endTime [] r1 <- postMeetings owner newMeeting r1.status `shouldMatchInt` 201 meeting <- assertOne r1.jsonBody - meetingId <- meeting %. "qualified_id" %. "id" >>= asString - domain <- meeting %. "qualified_id" %. "domain" >>= asString + (meetingId, domain) <- getMeetingIdAndDomain meeting let update = Aeson.object [ "title" Aeson..= ("Hijacked" :: Text), @@ -256,8 +246,7 @@ testMeetingDelete = do r1.status `shouldMatchInt` 201 meeting <- assertOne r1.jsonBody - meetingId <- meeting %. "qualified_id" %. "id" >>= asString - domain <- meeting %. "qualified_id" %. "domain" >>= asString + (meetingId, domain) <- getMeetingIdAndDomain meeting deleteMeeting owner domain meetingId `shouldMatchStatus` 200 @@ -277,20 +266,13 @@ testMeetingDeleteUnauthorized = do now <- liftIO getCurrentTime let startTime = addUTCTime 3600 now endTime = addUTCTime 7200 now - newMeeting = - Aeson.object - [ "title" Aeson..= ("Team Standup" :: Text), - "start_date" Aeson..= startTime, - "end_date" Aeson..= endTime, - "invited_emails" Aeson..= ([] :: [Text]) - ] + newMeeting = defaultMeetingJson "Team Standup" startTime endTime [] r1 <- postMeetings owner newMeeting r1.status `shouldMatchInt` 201 meeting <- assertOne r1.jsonBody - meetingId <- meeting %. "qualified_id" %. "id" >>= asString - domain <- meeting %. "qualified_id" %. "domain" >>= asString + (meetingId, domain) <- getMeetingIdAndDomain meeting deleteMeeting otherUser domain meetingId `shouldMatchStatus` 404 @@ -300,20 +282,13 @@ testMeetingAddInvitation = do now <- liftIO getCurrentTime let startTime = addUTCTime 3600 now endTime = addUTCTime 7200 now - newMeeting = - Aeson.object - [ "title" Aeson..= ("Team Standup" :: Text), - "start_date" Aeson..= startTime, - "end_date" Aeson..= endTime, - "invited_emails" Aeson..= (["alice@example.com"] :: [Text]) - ] + newMeeting = defaultMeetingJson "Team Standup" startTime endTime ["alice@example.com"] r1 <- postMeetings owner newMeeting r1.status `shouldMatchInt` 201 meeting <- assertOne r1.jsonBody - meetingId <- meeting %. "qualified_id" %. "id" >>= asString - domain <- meeting %. "qualified_id" %. "domain" >>= asString + (meetingId, domain) <- getMeetingIdAndDomain meeting let invitation = Aeson.object ["emails" Aeson..= ["bob@example.com" :: Text]] postMeetingInvitation owner domain meetingId invitation `shouldMatchStatus` 200 @@ -338,20 +313,13 @@ testMeetingRemoveInvitation = do now <- liftIO getCurrentTime let startTime = addUTCTime 3600 now endTime = addUTCTime 7200 now - newMeeting = - Aeson.object - [ "title" Aeson..= ("Team Standup" :: Text), - "start_date" Aeson..= startTime, - "end_date" Aeson..= endTime, - "invited_emails" Aeson..= (["alice@example.com", "bob@example.com"] :: [Text]) - ] + newMeeting = defaultMeetingJson "Team Standup" startTime endTime ["alice@example.com", "bob@example.com"] r1 <- postMeetings owner newMeeting r1.status `shouldMatchInt` 201 meeting <- assertOne r1.jsonBody - meetingId <- meeting %. "qualified_id" %. "id" >>= asString - domain <- meeting %. "qualified_id" %. "domain" >>= asString + (meetingId, domain) <- getMeetingIdAndDomain meeting let removeInvitation = Aeson.object ["emails" Aeson..= ["alice@example.com" :: Text]] deleteMeetingInvitation owner domain meetingId removeInvitation `shouldMatchStatus` 200 @@ -377,13 +345,7 @@ testMeetingCreatePersonalUserTrial = do now <- liftIO getCurrentTime let startTime = addUTCTime 3600 now endTime = addUTCTime 7200 now - newMeeting = - Aeson.object - [ "title" Aeson..= ("Personal Meeting" :: Text), - "start_date" Aeson..= startTime, - "end_date" Aeson..= endTime, - "invited_emails" Aeson..= ([] :: [Text]) - ] + newMeeting = defaultMeetingJson "Personal Meeting" startTime endTime [] r <- postMeetings personalUser newMeeting r.status `shouldMatchInt` 201 @@ -402,13 +364,7 @@ testMeetingCreateNonPayingTeamTrial = do now <- liftIO getCurrentTime let startTime = addUTCTime 3600 now endTime = addUTCTime 7200 now - newMeeting = - Aeson.object - [ "title" Aeson..= ("Non-Paying Team Meeting" :: Text), - "start_date" Aeson..= startTime, - "end_date" Aeson..= endTime, - "invited_emails" Aeson..= ([] :: [Text]) - ] + newMeeting = defaultMeetingJson "Non-Paying Team Meeting" startTime endTime [] r <- postMeetings owner newMeeting r.status `shouldMatchInt` 201 @@ -421,19 +377,13 @@ testMeetingCreatePayingTeamNonTrial :: (HasCallStack) => App () testMeetingCreatePayingTeamNonTrial = do (owner, tid, _members) <- createTeam OwnDomain 1 - let teamId = tid - putTeamFeature owner teamId "meetingPremium" (Aeson.object ["status" Aeson..= ("enabled" :: Text)]) `shouldMatchStatus` 200 + let firstMeeting = Aeson.object ["status" Aeson..= ("enabled" :: Text)] + putTeamFeature owner tid "meetingPremium" firstMeeting `shouldMatchStatus` 200 now <- liftIO getCurrentTime let startTime = addUTCTime 3600 now endTime = addUTCTime 7200 now - newMeeting = - Aeson.object - [ "title" Aeson..= ("Paying Team Meeting" :: Text), - "start_date" Aeson..= startTime, - "end_date" Aeson..= endTime, - "invited_emails" Aeson..= ([] :: [Text]) - ] + newMeeting = defaultMeetingJson "Paying Team Meeting" startTime endTime [] r <- postMeetings owner newMeeting r.status `shouldMatchInt` 201 @@ -447,19 +397,14 @@ testMeetingConfigDisabledBlocksCreate = do (owner, tid, _members) <- createTeam OwnDomain 1 -- Disable the MeetingConfig feature - let teamId = tid - putTeamFeature owner teamId "meeting" (Aeson.object ["status" Aeson..= ("disabled" :: Text), "lockStatus" Aeson..= ("unlocked" :: Text)]) `shouldMatchStatus` 200 + let firstMeeting = Aeson.object ["status" Aeson..= ("disabled" :: Text), "lockStatus" Aeson..= ("unlocked" :: Text)] + putTeamFeature owner tid "meeting" firstMeeting `shouldMatchStatus` 200 -- Try to create a meeting - should fail now <- liftIO getCurrentTime let startTime = addUTCTime 3600 now endTime = addUTCTime 7200 now - newMeeting = - Aeson.object - [ "title" Aeson..= ("Team Standup" :: Text), - "start_date" Aeson..= startTime, - "end_date" Aeson..= endTime - ] + newMeeting = defaultMeetingJson "Team Standup" startTime endTime [] postMeetings owner newMeeting `shouldMatchStatus` 403 @@ -472,18 +417,13 @@ testMeetingConfigDisabledBlocksList = do now <- liftIO getCurrentTime let startTime = addUTCTime 3600 now endTime = addUTCTime 7200 now - newMeeting = - Aeson.object - [ "title" Aeson..= ("Team Standup" :: Text), - "start_date" Aeson..= startTime, - "end_date" Aeson..= endTime - ] + newMeeting = defaultMeetingJson "Team Standup" startTime endTime [] postMeetings owner newMeeting `shouldMatchStatus` 201 -- Disable the MeetingConfig feature - let teamId = tid - putTeamFeature owner teamId "meeting" (Aeson.object ["status" Aeson..= ("disabled" :: Text), "lockStatus" Aeson..= ("unlocked" :: Text)]) `shouldMatchStatus` 200 + let updatedMeeting = Aeson.object ["status" Aeson..= ("disabled" :: Text), "lockStatus" Aeson..= ("unlocked" :: Text)] + putTeamFeature owner tid "meeting" updatedMeeting `shouldMatchStatus` 200 -- Try to list meetings - should fail getMeetingsList owner `shouldMatchStatus` 403 @@ -507,15 +447,14 @@ testMeetingRecurrence = do "start_date" Aeson..= startTime, "end_date" Aeson..= endTime, "recurrence" Aeson..= recurrence, - "invited_emails" Aeson..= (["charlie@example.com"] :: [Text]) + "invited_emails" Aeson..= ["charlie@example.com" :: Text] ] r1 <- postMeetings owner newMeeting r1.status `shouldMatchInt` 201 meeting <- assertOne r1.jsonBody - meetingId <- meeting %. "qualified_id" %. "id" >>= asString - domain <- meeting %. "qualified_id" %. "domain" >>= asString + (meetingId, domain) <- getMeetingIdAndDomain meeting r2 <- getMeeting owner domain meetingId r2.status `shouldMatchInt` 200 @@ -533,13 +472,7 @@ testMeetingCreateInvalidDates = do now <- liftIO getCurrentTime let startTime = addUTCTime 3600 now endTimeInvalid = addUTCTime 3500 now -- endDate is before startDate - newMeetingInvalid = - Aeson.object - [ "title" Aeson..= ("Invalid Date" :: Text), - "start_date" Aeson..= startTime, - "end_date" Aeson..= endTimeInvalid, - "invited_emails" Aeson..= ([] :: [Text]) - ] + newMeetingInvalid = defaultMeetingJson "Invalid Date" startTime endTimeInvalid [] postMeetings owner newMeetingInvalid `shouldMatchStatus` 403 @@ -549,20 +482,13 @@ testMeetingUpdateInvalidDates = do now <- liftIO getCurrentTime let startTime = addUTCTime 3600 now endTime = addUTCTime 7200 now - newMeeting = - Aeson.object - [ "title" Aeson..= ("Valid Meeting" :: Text), - "start_date" Aeson..= startTime, - "end_date" Aeson..= endTime, - "invited_emails" Aeson..= ([] :: [Text]) - ] + newMeeting = defaultMeetingJson "Valid Meeting" startTime endTime [] r1 <- postMeetings owner newMeeting r1.status `shouldMatchInt` 201 meeting <- assertOne r1.jsonBody - meetingId <- meeting %. "qualified_id" %. "id" >>= asString - domain <- meeting %. "qualified_id" %. "domain" >>= asString + (meetingId, domain) <- getMeetingIdAndDomain meeting let updatedStartTime = addUTCTime 1800 now updatedEndTimeInvalid = addUTCTime 1000 now -- endDate is before startDate updatedMeeting = From 6fd5b24ff1d4e99866b2d0e8715b07c0212b0734 Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Mon, 15 Dec 2025 10:38:16 +0100 Subject: [PATCH 19/29] fix(cleanup): ensure conversation is associated --- .../src/Wire/MeetingsSubsystem/Interpreter.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/MeetingsSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/MeetingsSubsystem/Interpreter.hs index c1440b3933..c270c69830 100644 --- a/libs/wire-subsystems/src/Wire/MeetingsSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/MeetingsSubsystem/Interpreter.hs @@ -307,12 +307,14 @@ cleanupOldMeetingsImpl cutoffTime batchSize = do -- 4. Delete associated conversations if they are meeting conversations -- We need to check if conversation has GroupConvType = MeetingConversation - for_ convIds $ \qConvId -> do + for_ (zip oldMeetings convIds) $ \(meeting, qConvId) -> do let convId = qUnqualified qConvId maybeConv <- ConvStore.getConversation convId case maybeConv of Just conv - | conv.metadata.cnvmGroupConvType == Just MeetingConversation -> + | conv.metadata.cnvmGroupConvType == Just MeetingConversation, + conv.id_ == convId, + meeting.conversationId == qConvId -> ConvStore.deleteConversation convId _ -> pure () From 94c87bc21887fed7287ca389afded530090c5e67 Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Mon, 15 Dec 2025 18:27:54 +0100 Subject: [PATCH 20/29] fix: listMeetingsImpl returns also meeting the user is a simple participants --- .../src/Wire/MeetingsSubsystem/Interpreter.hs | 74 +++++++++++++++---- 1 file changed, 61 insertions(+), 13 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/MeetingsSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/MeetingsSubsystem/Interpreter.hs index c270c69830..3fb88195da 100644 --- a/libs/wire-subsystems/src/Wire/MeetingsSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/MeetingsSubsystem/Interpreter.hs @@ -18,7 +18,9 @@ module Wire.MeetingsSubsystem.Interpreter where import Data.Id +import Data.Map qualified as Map import Data.Qualified +import Data.Range (Range, unsafeRange) import Data.Set qualified as Set import Data.Time.Clock (UTCTime, getCurrentTime) import Imports @@ -32,6 +34,7 @@ import Wire.API.User.Identity (EmailAddress) import Wire.ConversationStore qualified as ConvStore import Wire.MeetingsStore qualified as Store import Wire.MeetingsSubsystem +import Wire.Sem.Paging.Cassandra (ResultSet (..), ResultSetType (..)) import Wire.StoredConversation import Wire.UserList @@ -173,21 +176,66 @@ listMeetingsImpl zUser = do -- List all meetings created by the user createdMeetings <- Store.listMeetingsByUser (tUnqualified zUser) - -- Filter meetings to include only those where user is authorized - -- (creator or conversation member) - filterM (isAuthorized zUser) createdMeetings + -- Loop over local conversations accessible by the user, then filter to only keep meetings. + memberMeetings <- getAllMemberMeetings zUser + + -- Combine and deduplicate + let allMeetings = createdMeetings <> memberMeetings + uniqueMeetings = Map.elems $ Map.fromList [(m.id, m) | m <- allMeetings] + + pure uniqueMeetings + +getAllMemberMeetings :: + ( Member Store.MeetingsStore r, + Member ConvStore.ConversationStore r + ) => + Local UserId -> + Sem r [Meeting] +getAllMemberMeetings zUser = do + -- We process conversations in pages + processPage Nothing where - isAuthorized :: (Member ConvStore.ConversationStore r) => Local UserId -> Meeting -> Sem r Bool - isAuthorized lUser meeting = do - -- User is authorized if they are the creator - let isCreator = meeting.creator == tUntagged lUser - if isCreator - then pure True + processPage :: + ( Member Store.MeetingsStore r, + Member ConvStore.ConversationStore r + ) => + Maybe (Qualified ConvId) -> + Sem r [Meeting] + processPage lastId = do + let range = unsafeRange 1000 :: Range 1 1000 Int32 + resultSet <- ConvStore.getConversationIdsResultSet zUser range lastId + + let qConvIds = resultSet.resultSetResult + uConvIds = map qUnqualified qConvIds + + if null uConvIds + then pure [] else do - -- Or if they are a member of the associated conversation - let convId = qUnqualified meeting.conversationId - maybeMember <- ConvStore.getLocalMember convId (tUnqualified lUser) - pure $ isJust maybeMember + convs <- ConvStore.getConversations uConvIds + + let meetingConvs = filter isMeetingConv convs + meetingConvIds = Set.fromList $ map (.id_) meetingConvs + + -- Identify which Qualified ConvIds correspond to meeting conversations + -- We use the original Qualified IDs to query the meeting store + let targetQConvIds = filter (\qId -> qUnqualified qId `Set.member` meetingConvIds) qConvIds + + -- Fetch meetings for these conversations + pageMeetings <- forM targetQConvIds $ \qConvId -> do + Store.listMeetingsByConversation qConvId + + let currentMeetings = concat pageMeetings + + -- Check if there are more pages + case resultSet.resultSetType of + ResultSetTruncated -> do + -- Recurse with last ID + rest <- processPage (Just (last qConvIds)) + pure (currentMeetings <> rest) + ResultSetComplete -> pure currentMeetings + + isMeetingConv :: StoredConversation -> Bool + isMeetingConv conv = conv.metadata.cnvmGroupConvType == Just MeetingConversation updateMeetingImpl :: (Member Store.MeetingsStore r) => From ad40a6c01d5c7da9a0c394e5d22dcf656d091e37 Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Tue, 16 Dec 2025 00:41:42 +0100 Subject: [PATCH 21/29] refactor: split clean up and regular meeting subsystem, partially move api logic inn the subsystem --- .../ConversationSubsystem/Notification.hs | 264 ++++++++++++++++++ .../src/Wire/ConversationSubsystem/View.hs | 144 ++++++++++ .../src/Wire/MeetingsSubsystem.hs | 8 +- .../src/Wire/MeetingsSubsystem/Interpreter.hs | 116 ++++---- .../src/Wire/MeetingsSubsystemCleaning.hs | 32 +++ .../MeetingsSubsystemCleaning/Interpreter.hs | 76 +++++ libs/wire-subsystems/wire-subsystems.cabal | 4 + .../src/Wire/MeetingsCleanupWorker.hs | 6 +- services/galley/src/Galley/API/Meetings.hs | 58 ++-- services/galley/src/Galley/App.hs | 13 +- 10 files changed, 621 insertions(+), 100 deletions(-) create mode 100644 libs/wire-subsystems/src/Wire/ConversationSubsystem/Notification.hs create mode 100644 libs/wire-subsystems/src/Wire/ConversationSubsystem/View.hs create mode 100644 libs/wire-subsystems/src/Wire/MeetingsSubsystemCleaning.hs create mode 100644 libs/wire-subsystems/src/Wire/MeetingsSubsystemCleaning/Interpreter.hs diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Notification.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Notification.hs new file mode 100644 index 0000000000..5eb32cd1d3 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Notification.hs @@ -0,0 +1,264 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Wno-ambiguous-fields #-} + +module Wire.ConversationSubsystem.Notification where + +import Data.Bifunctor +import Data.Default +import Data.Id +import Data.Json.Util +import Data.List.Extra (nubOrd) +import Data.List.NonEmpty qualified as NE +import Data.List.NonEmpty (NonEmpty) +import Data.Qualified +import Data.Set qualified as Set +import Data.Singletons +import Data.Time +import Imports +import Network.AMQP qualified as Q +import Polysemy +import Polysemy.Error +import Polysemy.TinyLog qualified as P +import Wire.API.Component (Component(..)) +import Wire.API.Conversation hiding (Member, cnvAccess, cnvAccessRoles, cnvName, cnvType) +import Wire.API.Conversation qualified as Public +import Wire.API.Conversation.Action +import Wire.API.Conversation.Protocol +import Wire.API.Conversation.Role +import Wire.API.Error.Galley (UnreachableBackends(..)) +import Wire.API.Event.Conversation +import Wire.API.Federation.API (fedClient, sendBundle, makeConversationUpdateBundle) +import Wire.API.Federation.API.Galley +import Wire.API.Federation.Client (FederatorClient) +import Wire.API.Federation.Error +import Wire.API.Push.V2 qualified as PushV2 +import Wire.BackendNotificationQueueAccess +import Wire.ConversationStore +import Wire.ConversationSubsystem.View +import Wire.FederationAPIAccess +import Wire.FederationAPIAccess qualified as E +import Wire.NotificationSubsystem +import Wire.Sem.Now (Now) +import Wire.Sem.Now qualified as Now +import Wire.StoredConversation as Data + +toConversationCreated :: + UTCTime -> + Local UserId -> + StoredConversation -> + ConversationCreated ConvId +toConversationCreated now lusr StoredConversation {metadata = ConversationMetadata {..}, ..} = + ConversationCreated + { time = now, + origUserId = tUnqualified lusr, + cnvId = id_, + cnvType = cnvmType, + cnvAccess = cnvmAccess, + cnvAccessRoles = cnvmAccessRoles, + cnvName = cnvmName, + nonCreatorMembers = Set.empty, + messageTimer = cnvmMessageTimer, + receiptMode = cnvmReceiptMode, + protocol = protocol, + groupConvType = cnvmGroupConvType, + channelAddPermission = cnvmChannelAddPermission + } + +fromConversationCreated :: + Local x -> + ConversationCreated (Remote ConvId) -> + [(Public.Member, Public.OwnConversation)] +fromConversationCreated loc rc@ConversationCreated {..} = + let membersView = fmap (second Set.toList) . setHoles $ nonCreatorMembers + creatorOther = + OtherMember + (tUntagged (ccRemoteOrigUserId rc)) + Nothing + roleNameWireAdmin + in foldMap + ( \(me, others) -> + guard (inDomain me) $> let mem = toMember me in (mem, conv mem (creatorOther : others)) + ) + membersView + where + inDomain :: OtherMember -> Bool + inDomain = (== tDomain loc) . qDomain . Public.omQualifiedId + setHoles :: (Ord a) => Set a -> [(a, Set a)] + setHoles s = foldMap (\x -> [(x, Set.delete x s)]) s + toMember :: OtherMember -> Public.Member + toMember m = + Public.Member + { memId = Public.omQualifiedId m, + memService = Public.omService m, + memOtrMutedStatus = Nothing, + memOtrMutedRef = Nothing, + memOtrArchived = False, + memOtrArchivedRef = Nothing, + memHidden = False, + memHiddenRef = Nothing, + memConvRoleName = Public.omConvRoleName m + } + conv :: Public.Member -> [OtherMember] -> Public.OwnConversation + conv this others = + Public.OwnConversation + (tUntagged cnvId) + ConversationMetadata + { cnvmType = cnvType, + cnvmCreator = Just origUserId, + cnvmAccess = cnvAccess, + cnvmAccessRoles = cnvAccessRoles, + cnvmName = cnvName, + cnvmTeam = Nothing, + cnvmMessageTimer = messageTimer, + cnvmReceiptMode = receiptMode, + cnvmGroupConvType = groupConvType, + cnvmChannelAddPermission = channelAddPermission, + cnvmCellsState = def, + cnvmParent = Nothing + } + (OwnConvMembers this others) + ProtocolProteus + +ensureNoUnreachableBackends :: + (Member (Error UnreachableBackends) r) => + [Either (Remote e, b) a] -> + Sem r [a] +ensureNoUnreachableBackends results = do + let (errors, values) = partitionEithers results + unless (null errors) $ + throw (UnreachableBackends (map (tDomain . fst) errors)) + pure values + +registerRemoteConversationMemberships :: + ( Member ConversationStore r, + Member (Error UnreachableBackends) r, + Member (Error FederationError) r, + Member BackendNotificationQueueAccess r, + Member (FederationAPIAccess FederatorClient) r + ) => + UTCTime -> + Local UserId -> + Local StoredConversation -> + JoinType -> + Sem r () +registerRemoteConversationMemberships now lusr lc joinType = deleteOnUnreachable $ do + let c = tUnqualified lc + rc = toConversationCreated now lusr c + allRemoteMembers = nubOrd c.remoteMembers + allRemoteMembersQualified = remoteMemberQualify <$> allRemoteMembers + allRemoteBuckets :: [Remote [RemoteMember]] = bucketRemote allRemoteMembersQualified + + void . (ensureNoUnreachableBackends =<<) $ + runFederatedConcurrentlyEither allRemoteMembersQualified $ \_ -> + void $ fedClient @'Brig @"api-version" () + + void . (ensureNoUnreachableBackends =<<) $ + runFederatedConcurrentlyEither allRemoteMembersQualified $ + \rrms -> + fedClient @'Galley @"on-conversation-created" + ( rc + { nonCreatorMembers = + toMembers (tUnqualified rrms) + } + ) + + let joined :: [Remote [RemoteMember]] = allRemoteBuckets + joinedCoupled :: [Remote ([RemoteMember], NonEmpty (Remote UserId))] + joinedCoupled = + foldMap + ( \ruids -> + let nj = + foldMap (fmap (.id_) . tUnqualified) $ + filter (\r -> tDomain r /= tDomain ruids) joined + in case NE.nonEmpty nj of + Nothing -> [] + Just v -> [fmap (,v) ruids] + ) + joined + + void $ enqueueNotificationsConcurrentlyBuckets Q.Persistent joinedCoupled $ \z -> + makeConversationUpdateBundle (convUpdateJoin z) >>= sendBundle + where + creator :: Maybe UserId + creator = cnvmCreator . (.metadata) . tUnqualified $ lc + + localNonCreators :: [OtherMember] + localNonCreators = + fmap (localMemberToOther . tDomain $ lc) + . filter (\lm -> lm.id_ `notElem` creator) + . (.localMembers) + . tUnqualified + $ lc + + toMembers :: [RemoteMember] -> Set OtherMember + toMembers rs = Set.fromList $ localNonCreators <> fmap remoteMemberToOther rs + + convUpdateJoin :: Remote ([RemoteMember], NonEmpty (Remote UserId)) -> ConversationUpdate + convUpdateJoin (tUnqualified -> (toNotify, newMembers)) = + ConversationUpdate + { time = now, + origUserId = tUntagged lusr, + convId = (tUnqualified lc).id_, + alreadyPresentUsers = fmap (\m -> tUnqualified $ m.id_) toNotify, + action = + SomeConversationAction + (sing @'ConversationJoinTag) + (ConversationJoin (tUntagged <$> newMembers) roleNameWireMember joinType), + extraConversationData = def + } + + deleteOnUnreachable :: + ( Member ConversationStore r, + Member (Error UnreachableBackends) r + ) => + Sem r a -> + Sem r a + deleteOnUnreachable m = catch @UnreachableBackends m $ \e -> do + deleteConversation (tUnqualified lc).id_ + throw e + +notifyCreatedConversation :: + ( Member ConversationStore r, + Member (Error FederationError) r, + Member (Error ViewError) r, + Member (Error UnreachableBackends) r, + Member (FederationAPIAccess FederatorClient) r, + Member NotificationSubsystem r, + Member BackendNotificationQueueAccess r, + Member Now r, + Member P.TinyLog r + ) => + Local UserId -> + Maybe ConnId -> + StoredConversation -> + JoinType -> + Sem r () +notifyCreatedConversation lusr conn c joinType = do + now <- Now.get + registerRemoteConversationMemberships now lusr (qualifyAs lusr c) joinType + unless (null c.remoteMembers) $ + unlessM E.isFederationConfigured $ + throw FederationNotConfigured + + pushNotifications =<< mapM (toPush now) c.localMembers + where + route + | Data.convType c == RegularConv = PushV2.RouteAny + | otherwise = PushV2.RouteDirect + toPush t m = do + let remoteOthers = remoteMemberToOther <$> c.remoteMembers + localOthers = map (localMemberToOther (tDomain lusr)) $ c.localMembers + lconv = qualifyAs lusr c.id_ + c' <- conversationViewWithCachedOthers remoteOthers localOthers c (qualifyAs lusr m.id_) + let e = Event (tUntagged lconv) Nothing (EventFromUser (tUntagged lusr)) t Nothing (EdConversation c') + pure $ + def + { origin = Just (tUnqualified lusr), + json = toJSONObject e, + recipients = [localMemberToRecipient m], + isCellsEvent = False, + route, + conn + } diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/View.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/View.hs new file mode 100644 index 0000000000..9640f5e177 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/View.hs @@ -0,0 +1,144 @@ +{-# LANGUAGE RecordWildCards #-} +module Wire.ConversationSubsystem.View where + +import Data.Domain (Domain) +import Data.Id (UserId, idToText) +import Data.Qualified +import Imports +import Polysemy +import Polysemy.Error +import Polysemy.TinyLog qualified as P +import System.Logger.Message (msg, val, (+++)) +import Wire.API.Conversation hiding (Member) +import Wire.API.Conversation qualified as Conversation +import Wire.API.Federation.API.Galley +import Wire.StoredConversation + +data ViewError = BadMemberState + deriving (Show, Eq) + +conversationViewV9 :: + ( Member (Error ViewError) r, + Member P.TinyLog r + ) => + Local UserId -> + StoredConversation -> + Sem r OwnConversation +conversationViewV9 luid conv = do + let remoteOthers = map remoteMemberToOther $ conv.remoteMembers + localOthers = map (localMemberToOther (tDomain luid)) $ conv.localMembers + conversationViewWithCachedOthers remoteOthers localOthers conv luid + +conversationView :: + Local x -> + Maybe (Local UserId) -> + StoredConversation -> + Conversation +conversationView l luid conv = + let remoteMembers = map remoteMemberToOther $ conv.remoteMembers + localMembers = map (localMemberToOther (tDomain l)) $ conv.localMembers + selfs = filter (\m -> fmap tUnqualified luid == Just m.id_) (conv.localMembers) + mSelf = localMemberToSelf l <$> listToMaybe selfs + others = filter (\oth -> (tUntagged <$> luid) /= Just (omQualifiedId oth)) localMembers <> remoteMembers + in Conversation + { members = ConvMembers mSelf others, + qualifiedId = (tUntagged . qualifyAs l $ conv.id_), + metadata = conv.metadata, + protocol = conv.protocol + } + +conversationViewWithCachedOthers :: + ( Member (Error ViewError) r, + Member P.TinyLog r + ) => + [OtherMember] -> + [OtherMember] -> + StoredConversation -> + Local UserId -> + Sem r OwnConversation +conversationViewWithCachedOthers remoteOthers localOthers conv luid = do + let mbConv = conversationViewMaybe luid remoteOthers localOthers conv + maybe memberNotFound pure mbConv + where + memberNotFound = do + P.err . msg $ + val "User " + +++ idToText (tUnqualified luid) + +++ val " is not a member of conv " + +++ idToText conv.id_ + throw BadMemberState + +conversationViewMaybe :: Local UserId -> [OtherMember] -> [OtherMember] -> StoredConversation -> Maybe OwnConversation +conversationViewMaybe luid remoteOthers localOthers conv = do + let selfs = filter (\m -> tUnqualified luid == m.id_) conv.localMembers + self <- localMemberToSelf luid <$> listToMaybe selfs + let others = filter (\oth -> tUntagged luid /= omQualifiedId oth) localOthers <> remoteOthers + pure $ + OwnConversation + (tUntagged . qualifyAs luid $ conv.id_) + conv.metadata + (OwnConvMembers self others) + conv.protocol + +remoteConversationView :: + Local UserId -> + MemberStatus -> + Remote RemoteConversationV2 -> + OwnConversation +remoteConversationView uid status (tUntagged -> Qualified rconv rDomain) = + let mems = rconv.members + others = mems.others + self = + localMemberToSelf + uid + LocalMember + { id_ = tUnqualified uid, + service = Nothing, + status = status, + convRoleName = mems.selfRole + } + in OwnConversation + (Qualified rconv.id rDomain) + rconv.metadata + (OwnConvMembers self others) + rconv.protocol + +conversationToRemote :: + Domain -> + Remote UserId -> + StoredConversation -> + Maybe RemoteConversationV2 +conversationToRemote localDomain ruid conv = do + let (selfs, rothers) = partition (\r -> r.id_ == ruid) (conv.remoteMembers) + lothers = conv.localMembers + selfRole' <- (.convRoleName) <$> listToMaybe selfs + let others' = + map (localMemberToOther localDomain) lothers + <> map remoteMemberToOther rothers + pure $ + RemoteConversationV2 + { id = conv.id_, + metadata = conv.metadata, + members = + RemoteConvMembers + { selfRole = selfRole', + others = others' + }, + protocol = conv.protocol + } + +localMemberToSelf :: Local x -> LocalMember -> Conversation.Member +localMemberToSelf loc lm = + Conversation.Member + { memId = tUntagged . qualifyAs loc $ lm.id_, + memService = lm.service, + memOtrMutedStatus = msOtrMutedStatus st, + memOtrMutedRef = msOtrMutedRef st, + memOtrArchived = msOtrArchived st, + memOtrArchivedRef = msOtrArchivedRef st, + memHidden = msHidden st, + memHiddenRef = msHiddenRef st, + memConvRoleName = lm.convRoleName + } + where + st = lm.status diff --git a/libs/wire-subsystems/src/Wire/MeetingsSubsystem.hs b/libs/wire-subsystems/src/Wire/MeetingsSubsystem.hs index 57bf1f5d2a..e0d247281e 100644 --- a/libs/wire-subsystems/src/Wire/MeetingsSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/MeetingsSubsystem.hs @@ -21,7 +21,6 @@ module Wire.MeetingsSubsystem where import Data.Id import Data.Qualified -import Data.Time.Clock (UTCTime) import Imports import Polysemy import Wire.API.Meeting @@ -32,7 +31,7 @@ data MeetingsSubsystem m a where CreateMeeting :: Local UserId -> NewMeeting -> - -- | trial: True if this is a trial meeting + -- | premium: True if this is a premium meeting Bool -> MeetingsSubsystem m (Meeting, StoredConversation) GetMeeting :: @@ -61,10 +60,5 @@ data MeetingsSubsystem m a where Qualified MeetingId -> [EmailAddress] -> MeetingsSubsystem m Bool - -- Cleanup operation - CleanupOldMeetings :: - UTCTime -> - Int -> - MeetingsSubsystem m Int64 makeSem ''MeetingsSubsystem diff --git a/libs/wire-subsystems/src/Wire/MeetingsSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/MeetingsSubsystem/Interpreter.hs index 3fb88195da..6be87b8b05 100644 --- a/libs/wire-subsystems/src/Wire/MeetingsSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/MeetingsSubsystem/Interpreter.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE RecordWildCards #-} + -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2025 Wire Swiss GmbH @@ -22,13 +24,16 @@ import Data.Map qualified as Map import Data.Qualified import Data.Range (Range, unsafeRange) import Data.Set qualified as Set -import Data.Time.Clock (UTCTime, getCurrentTime) +import Data.Time.Clock (getCurrentTime) import Imports import Polysemy import Wire.API.Conversation hiding (Member) import Wire.API.Conversation.CellsState (CellsState (CellsDisabled)) import Wire.API.Conversation.Role (roleNameWireAdmin) -import Wire.API.Meeting +import Wire.API.Error (ErrorS) +import Wire.API.Error hiding (DynError, ErrorS) +import Wire.API.Error.Galley +import Wire.API.Meeting qualified as API import Wire.API.User (BaseProtocolTag (BaseProtocolMLSTag)) import Wire.API.User.Identity (EmailAddress) import Wire.ConversationStore qualified as ConvStore @@ -36,22 +41,26 @@ import Wire.MeetingsStore qualified as Store import Wire.MeetingsSubsystem import Wire.Sem.Paging.Cassandra (ResultSet (..), ResultSetType (..)) import Wire.StoredConversation +import Wire.TeamStore qualified as TeamStore import Wire.UserList interpretMeetingsSubsystem :: ( Member Store.MeetingsStore r, Member ConvStore.ConversationStore r, - Member (Embed IO) r + Member TeamStore.TeamStore r, + Member (Embed IO) r, + Member (ErrorS 'NotATeamMember) r, + Member (ErrorS 'InvalidOperation) r ) => InterpreterFor MeetingsSubsystem r interpretMeetingsSubsystem = interpret $ \case - CreateMeeting zUser newMeeting trial -> - createMeetingImpl zUser newMeeting trial + CreateMeeting zUser newMeeting premium -> + createMeetingImpl zUser newMeeting premium GetMeeting zUser meetingId -> getMeetingImpl zUser meetingId ListMeetings zUser -> listMeetingsImpl zUser - Wire.MeetingsSubsystem.UpdateMeeting zUser meetingId update -> + UpdateMeeting zUser meetingId update -> updateMeetingImpl zUser meetingId update DeleteMeeting zUser meetingId -> deleteMeetingImpl zUser meetingId @@ -59,19 +68,35 @@ interpretMeetingsSubsystem = interpret $ \case addInvitedEmailsImpl zUser meetingId emails RemoveInvitedEmails zUser meetingId emails -> removeInvitedEmailsImpl zUser meetingId emails - CleanupOldMeetings cutoffTime batchSize -> - cleanupOldMeetingsImpl cutoffTime batchSize createMeetingImpl :: ( Member Store.MeetingsStore r, Member ConvStore.ConversationStore r, - Member (Embed IO) r + Member TeamStore.TeamStore r, + Member (Embed IO) r, + Member (ErrorS 'NotATeamMember) r, + Member (ErrorS 'InvalidOperation) r ) => Local UserId -> - NewMeeting -> + API.NewMeeting -> Bool -> - Sem r (Meeting, StoredConversation) -createMeetingImpl zUser newMeeting trial = do + Sem r (API.Meeting, StoredConversation) +createMeetingImpl zUser newMeeting premium = do + -- Validate that endDate > startDate + when (newMeeting.endDate <= newMeeting.startDate) $ + throwS @'InvalidOperation + + -- Determine trial status based on team membership and premium feature + maybeTeamId <- TeamStore.getOneUserTeam (tUnqualified zUser) + trial <- case maybeTeamId of + Nothing -> pure True -- Personal users create trial meetings + Just teamId -> do + -- Verify user is a team member (not just a collaborator) + maybeMember <- TeamStore.getTeamMember teamId (tUnqualified zUser) + case maybeMember of + Nothing -> throwS @'NotATeamMember -- User not a member + Just _member -> pure $ not premium + -- Generate meeting ID meetingId <- randomId let qMeetingId = tUntagged (qualifyAs zUser meetingId) @@ -125,7 +150,7 @@ createMeetingImpl zUser newMeeting trial = do now <- liftIO getCurrentTime -- Return created meeting pure - ( Meeting + ( API.Meeting { id = qMeetingId, title = newMeeting.title, creator = tUntagged zUser, @@ -146,7 +171,7 @@ getMeetingImpl :: ) => Local UserId -> Qualified MeetingId -> - Sem r (Maybe Meeting) + Sem r (Maybe API.Meeting) getMeetingImpl zUser meetingId = do -- Get meeting from store maybeMeeting <- Store.getMeeting meetingId @@ -171,7 +196,7 @@ listMeetingsImpl :: Member ConvStore.ConversationStore r ) => Local UserId -> - Sem r [Meeting] + Sem r [API.Meeting] listMeetingsImpl zUser = do -- List all meetings created by the user createdMeetings <- Store.listMeetingsByUser (tUnqualified zUser) @@ -190,7 +215,7 @@ getAllMemberMeetings :: Member ConvStore.ConversationStore r ) => Local UserId -> - Sem r [Meeting] + Sem r [API.Meeting] getAllMemberMeetings zUser = do -- We process conversations in pages processPage Nothing @@ -200,7 +225,7 @@ getAllMemberMeetings zUser = do Member ConvStore.ConversationStore r ) => Maybe (Qualified ConvId) -> - Sem r [Meeting] + Sem r [API.Meeting] processPage lastId = do let range = unsafeRange 1000 :: Range 1 1000 Int32 resultSet <- ConvStore.getConversationIdsResultSet zUser range lastId @@ -238,12 +263,21 @@ getAllMemberMeetings zUser = do isMeetingConv conv = conv.metadata.cnvmGroupConvType == Just MeetingConversation updateMeetingImpl :: - (Member Store.MeetingsStore r) => + ( Member Store.MeetingsStore r, + Member (ErrorS 'InvalidOperation) r + ) => Local UserId -> Qualified MeetingId -> - UpdateMeeting -> - Sem r (Maybe Meeting) + API.UpdateMeeting -> + Sem r (Maybe API.Meeting) updateMeetingImpl zUser meetingId update = do + when (isNothing update.title && isNothing update.startDate && isNothing update.endDate && isNothing update.recurrence) $ + throwS @'InvalidOperation + + case (update.startDate, update.endDate) of + (Just start, Just end) -> when (end <= start) $ throwS @'InvalidOperation + _ -> pure () + -- Get existing meeting maybeMeeting <- Store.getMeeting meetingId case maybeMeeting of @@ -293,7 +327,8 @@ deleteMeetingImpl zUser meetingId = do pure True addInvitedEmailsImpl :: - (Member Store.MeetingsStore r) => + ( Member Store.MeetingsStore r + ) => Local UserId -> Qualified MeetingId -> [EmailAddress] -> @@ -313,7 +348,8 @@ addInvitedEmailsImpl zUser meetingId emails = do pure True removeInvitedEmailsImpl :: - (Member Store.MeetingsStore r) => + ( Member Store.MeetingsStore r + ) => Local UserId -> Qualified MeetingId -> [EmailAddress] -> @@ -331,39 +367,3 @@ removeInvitedEmailsImpl zUser meetingId emails = do -- Remove invited email Store.removeInvitedEmails meetingId emails pure True - -cleanupOldMeetingsImpl :: - ( Member Store.MeetingsStore r, - Member ConvStore.ConversationStore r - ) => - UTCTime -> - Int -> - Sem r Int64 -cleanupOldMeetingsImpl cutoffTime batchSize = do - -- 1. Fetch old meetings - oldMeetings <- Store.getOldMeetings cutoffTime batchSize - - if null oldMeetings - then pure 0 - else do - -- 2. Extract meeting IDs and conversation IDs - let meetingIds = map (.id) oldMeetings - convIds = map (.conversationId) oldMeetings - - -- 3. Delete meetings from database - deletedCount <- Store.deleteMeetingBatch meetingIds - - -- 4. Delete associated conversations if they are meeting conversations - -- We need to check if conversation has GroupConvType = MeetingConversation - for_ (zip oldMeetings convIds) $ \(meeting, qConvId) -> do - let convId = qUnqualified qConvId - maybeConv <- ConvStore.getConversation convId - case maybeConv of - Just conv - | conv.metadata.cnvmGroupConvType == Just MeetingConversation, - conv.id_ == convId, - meeting.conversationId == qConvId -> - ConvStore.deleteConversation convId - _ -> pure () - - pure deletedCount diff --git a/libs/wire-subsystems/src/Wire/MeetingsSubsystemCleaning.hs b/libs/wire-subsystems/src/Wire/MeetingsSubsystemCleaning.hs new file mode 100644 index 0000000000..eaf9f8a500 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/MeetingsSubsystemCleaning.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2025 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.MeetingsSubsystemCleaning where + +import Data.Time.Clock (UTCTime) +import Imports +import Polysemy + +data MeetingsSubsystemCleaning m a where + CleanupOldMeetings :: + UTCTime -> + Int -> + MeetingsSubsystemCleaning m Int64 + +makeSem ''MeetingsSubsystemCleaning diff --git a/libs/wire-subsystems/src/Wire/MeetingsSubsystemCleaning/Interpreter.hs b/libs/wire-subsystems/src/Wire/MeetingsSubsystemCleaning/Interpreter.hs new file mode 100644 index 0000000000..783a2e634e --- /dev/null +++ b/libs/wire-subsystems/src/Wire/MeetingsSubsystemCleaning/Interpreter.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE RecordWildCards #-} +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2025 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.MeetingsSubsystemCleaning.Interpreter where + +import Data.Qualified (qUnqualified) +import Data.Time.Clock (UTCTime) +import Imports +import Polysemy +import Wire.API.Conversation (GroupConvType (MeetingConversation), cnvmGroupConvType) +import Wire.API.Meeting (Meeting(..)) +import Wire.ConversationStore qualified as ConvStore +import Wire.MeetingsStore qualified as Store +import Wire.MeetingsSubsystemCleaning +import Wire.StoredConversation (StoredConversation(..)) + +interpretMeetingsSubsystemCleaning :: + ( Member Store.MeetingsStore r, + Member ConvStore.ConversationStore r + ) => + InterpreterFor MeetingsSubsystemCleaning r +interpretMeetingsSubsystemCleaning = interpret $ \case + CleanupOldMeetings cutoffTime batchSize -> + cleanupOldMeetingsImpl cutoffTime batchSize + +cleanupOldMeetingsImpl :: + ( Member Store.MeetingsStore r, + Member ConvStore.ConversationStore r + ) => + UTCTime -> + Int -> + Sem r Int64 +cleanupOldMeetingsImpl cutoffTime batchSize = do + -- 1. Fetch old meetings + oldMeetings <- Store.getOldMeetings cutoffTime batchSize + + if null oldMeetings + then pure 0 + else do + -- 2. Extract meeting IDs and conversation IDs + let meetingIds = map (\Meeting{id = mid} -> mid) oldMeetings + convIds = map (\Meeting{conversationId = cid} -> cid) oldMeetings + + -- 3. Delete meetings from database + deletedCount <- Store.deleteMeetingBatch meetingIds + + -- 4. Delete associated conversations if they are meeting conversations + -- We need to check if conversation has GroupConvType = MeetingConversation + for_ (zip oldMeetings convIds) $ \(meeting, qConvId) -> do + let convId = qUnqualified qConvId + maybeConv <- ConvStore.getConversation convId + case maybeConv of + Just conv + | conv.metadata.cnvmGroupConvType == Just MeetingConversation, + conv.id_ == convId, + meeting.conversationId == qConvId -> + ConvStore.deleteConversation convId + _ -> pure () + + pure deletedCount diff --git a/libs/wire-subsystems/wire-subsystems.cabal b/libs/wire-subsystems/wire-subsystems.cabal index afcd81561d..87f92bf489 100644 --- a/libs/wire-subsystems/wire-subsystems.cabal +++ b/libs/wire-subsystems/wire-subsystems.cabal @@ -226,6 +226,8 @@ library Wire.ConversationStore.Postgres Wire.ConversationSubsystem Wire.ConversationSubsystem.Interpreter + Wire.ConversationSubsystem.Notification + Wire.ConversationSubsystem.View Wire.DeleteQueue Wire.DeleteQueue.InMemory Wire.DomainRegistrationStore @@ -276,6 +278,8 @@ library Wire.MeetingsStore.Postgres Wire.MeetingsSubsystem Wire.MeetingsSubsystem.Interpreter + Wire.MeetingsSubsystemCleaning + Wire.MeetingsSubsystemCleaning.Interpreter Wire.NotificationSubsystem Wire.NotificationSubsystem.Interpreter Wire.PaginationState diff --git a/services/background-worker/src/Wire/MeetingsCleanupWorker.hs b/services/background-worker/src/Wire/MeetingsCleanupWorker.hs index 879af23385..050f0f5778 100644 --- a/services/background-worker/src/Wire/MeetingsCleanupWorker.hs +++ b/services/background-worker/src/Wire/MeetingsCleanupWorker.hs @@ -36,8 +36,8 @@ import Wire.BackgroundWorker.Options (MeetingsCleanupConfig (..)) import Wire.BackgroundWorker.Util (CleanupAction) import Wire.ConversationStore.Postgres (interpretConversationStoreToPostgres) import Wire.MeetingsStore.Postgres (interpretMeetingsStoreToPostgres) -import Wire.MeetingsSubsystem qualified as Meetings -import Wire.MeetingsSubsystem.Interpreter (interpretMeetingsSubsystem) +import Wire.MeetingsSubsystemCleaning qualified as Meetings +import Wire.MeetingsSubsystemCleaning.Interpreter (interpretMeetingsSubsystemCleaning) data CleanupConfig = CleanupConfig { retentionHours :: Int, @@ -135,5 +135,5 @@ runMeetingsCleanup env cutoffTime batchSize = . interpretMeetingsStoreToPostgres . runInputConst env.hasqlPool . interpretConversationStoreToPostgres - . interpretMeetingsSubsystem + . interpretMeetingsSubsystemCleaning $ Meetings.cleanupOldMeetings cutoffTime batchSize diff --git a/services/galley/src/Galley/API/Meetings.hs b/services/galley/src/Galley/API/Meetings.hs index 877a32f30a..3a4fb83df4 100644 --- a/services/galley/src/Galley/API/Meetings.hs +++ b/services/galley/src/Galley/API/Meetings.hs @@ -31,12 +31,11 @@ import Data.Id import Data.Qualified import Galley.API.Error import Galley.API.Teams.Features.Get (getFeatureForTeam) -import Galley.API.Util -import Galley.Effects +import Galley.Effects.TeamFeatureStore import Galley.Options (Opts) import Imports import Polysemy -import Polysemy.Error +import Polysemy.Error (Error, runError, throw) import Polysemy.Input import Polysemy.TinyLog qualified as P import Wire.API.Conversation (JoinType (InternalAdd)) @@ -46,7 +45,11 @@ import Wire.API.Federation.Client (FederatorClient) import Wire.API.Federation.Error import Wire.API.Meeting import Wire.API.Team.Feature (FeatureStatus (..), LockableFeature (..), MeetingConfig, MeetingPremiumConfig) -import Wire.FederationAPIAccess () +import Wire.BackendNotificationQueueAccess +import Wire.ConversationStore (ConversationStore) +import Wire.ConversationSubsystem.Notification (notifyCreatedConversation) +import Wire.ConversationSubsystem.View qualified as ViewError +import Wire.FederationAPIAccess (FederationAPIAccess) import Wire.MeetingsSubsystem qualified as Meetings import Wire.NotificationSubsystem import Wire.Sem.Now (Now) @@ -54,7 +57,7 @@ import Wire.TeamStore qualified as TeamStore -- | Check if meetings feature is enabled for the user (if they're in a team) checkMeetingsEnabled :: - ( Member TeamStore r, + ( Member TeamStore.TeamStore r, Member TeamFeatureStore r, Member (ErrorS 'InvalidOperation) r, Member (Input Opts) r @@ -73,7 +76,6 @@ checkMeetingsEnabled userId = do createMeeting :: ( Member Meetings.MeetingsSubsystem r, Member (ErrorS 'InvalidOperation) r, - Member (ErrorS 'NotATeamMember) r, Member BackendNotificationQueueAccess r, Member ConversationStore r, Member (Error FederationError) r, @@ -83,7 +85,7 @@ createMeeting :: Member NotificationSubsystem r, Member Now r, Member P.TinyLog r, - Member TeamStore r, + Member TeamStore.TeamStore r, Member TeamFeatureStore r, Member (Input Opts) r ) => @@ -94,33 +96,27 @@ createMeeting lUser newMeeting = do -- Check if meetings feature is enabled checkMeetingsEnabled (tUnqualified lUser) - -- Validate that endDate > startDate - when (newMeeting.endDate <= newMeeting.startDate) $ - throwS @'InvalidOperation - - -- Determine trial status based on team membership and premium feature maybeTeamId <- TeamStore.getOneUserTeam (tUnqualified lUser) - trial <- case maybeTeamId of + premium <- case maybeTeamId of Nothing -> pure True -- Personal users create trial meetings Just teamId -> do - -- Verify user is a team member (not just a collaborator) - maybeMember <- TeamStore.getTeamMember teamId (tUnqualified lUser) - case maybeMember of - Nothing -> throwS @'NotATeamMember -- User not a member - Just _member -> do - -- Check meeting premium feature status to determine trial - premiumFeature <- getFeatureForTeam @MeetingPremiumConfig teamId - pure $ case premiumFeature of - LockableFeature {status = FeatureStatusEnabled} -> False -- premium team, not trial - _ -> True -- non-premium team or disabled, is trial - (meeting, conversation) <- Meetings.createMeeting lUser newMeeting trial - notifyCreatedConversation lUser Nothing conversation InternalAdd + premiumFeature <- getFeatureForTeam @MeetingPremiumConfig teamId + pure $ case premiumFeature of + LockableFeature {status = FeatureStatusEnabled} -> True + _ -> False + + (meeting, conversation) <- Meetings.createMeeting lUser newMeeting premium + res <- runError @ViewError.ViewError $ notifyCreatedConversation lUser Nothing conversation InternalAdd + case res of + Left ViewError.BadMemberState -> throw (InternalErrorWithDescription "Internal error: Member state inconsistent") + Right () -> pure () + pure meeting getMeeting :: ( Member Meetings.MeetingsSubsystem r, Member (ErrorS 'MeetingNotFound) r, - Member TeamStore r, + Member TeamStore.TeamStore r, Member TeamFeatureStore r, Member (ErrorS 'InvalidOperation) r, Member (Input Opts) r @@ -139,7 +135,7 @@ getMeeting zUser domain meetingId = do listMeetings :: ( Member Meetings.MeetingsSubsystem r, - Member TeamStore r, + Member TeamStore.TeamStore r, Member TeamFeatureStore r, Member (ErrorS 'InvalidOperation) r, Member (Input Opts) r @@ -154,7 +150,7 @@ updateMeeting :: ( Member Meetings.MeetingsSubsystem r, Member (ErrorS 'MeetingNotFound) r, Member (ErrorS 'InvalidOperation) r, - Member TeamStore r, + Member TeamStore.TeamStore r, Member TeamFeatureStore r, Member (Input Opts) r ) => @@ -182,7 +178,7 @@ deleteMeeting :: ( Member Meetings.MeetingsSubsystem r, Member (ErrorS 'MeetingNotFound) r, Member (ErrorS 'InvalidOperation) r, - Member TeamStore r, + Member TeamStore.TeamStore r, Member TeamFeatureStore r, Member (Input Opts) r ) => @@ -200,7 +196,7 @@ addMeetingInvitation :: ( Member Meetings.MeetingsSubsystem r, Member (ErrorS 'MeetingNotFound) r, Member (ErrorS 'InvalidOperation) r, - Member TeamStore r, + Member TeamStore.TeamStore r, Member TeamFeatureStore r, Member (Input Opts) r ) => @@ -219,7 +215,7 @@ removeMeetingInvitation :: ( Member Meetings.MeetingsSubsystem r, Member (ErrorS 'MeetingNotFound) r, Member (ErrorS 'InvalidOperation) r, - Member TeamStore r, + Member TeamStore.TeamStore r, Member TeamFeatureStore r, Member (Input Opts) r ) => diff --git a/services/galley/src/Galley/App.hs b/services/galley/src/Galley/App.hs index 73c477ede5..79a2fb86af 100644 --- a/services/galley/src/Galley/App.hs +++ b/services/galley/src/Galley/App.hs @@ -123,6 +123,7 @@ import Wire.MeetingsStore.Postgres (interpretMeetingsStoreToPostgres) import Wire.MeetingsSubsystem.Interpreter import Wire.NotificationSubsystem.Interpreter (runNotificationSubsystemGundeck) import Wire.ParseException +import Wire.Postgres (PGConstraints) import Wire.ProposalStore.Cassandra import Wire.RateLimit import Wire.RateLimit.Interpreter @@ -284,7 +285,17 @@ logAndMapError fErr fLog logMsg action = evalGalley :: Env -> Sem GalleyEffects a -> ExceptT JSONResponse IO a evalGalley e = - let convStoreInterpreter = + let convStoreInterpreter :: + forall r a. + ( Member TinyLog r, + PGConstraints r, + Member Async r, + Member (Error MigrationError) r, + Member Race r + ) => + Sem (ConversationStore ': r) a -> + Sem r a + convStoreInterpreter = case (e ^. options . postgresMigration).conversation of CassandraStorage -> interpretConversationStoreToCassandra (e ^. cstate) MigrationToPostgresql -> interpretConversationStoreToCassandraAndPostgres (e ^. cstate) From 7f72decd86f5c023f9ee6893c1dd6fccdd11abeb Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Tue, 16 Dec 2025 15:18:47 +0100 Subject: [PATCH 22/29] fix: patching meeting dates --- integration/test/Test/Meetings.hs | 156 +++++++++++------- .../src/Wire/MeetingsSubsystem/Interpreter.hs | 9 +- 2 files changed, 104 insertions(+), 61 deletions(-) diff --git a/integration/test/Test/Meetings.hs b/integration/test/Test/Meetings.hs index ef4f4537df..83715524cf 100644 --- a/integration/test/Test/Meetings.hs +++ b/integration/test/Test/Meetings.hs @@ -9,62 +9,6 @@ import Data.Time.Clock import SetupHelpers import Testlib.Prelude as P -shouldMatchStatus :: (HasCallStack) => App Response -> Int -> App () -shouldMatchStatus mkResp expectedStatus = do - resp <- mkResp - resp.status `shouldMatchInt` expectedStatus - --- Custom API helper functions for meetings -postMeetings :: (HasCallStack, MakesValue user) => user -> Aeson.Value -> App Response -postMeetings user newMeeting = do - req <- baseRequest user Galley Versioned "/meetings" - submit "POST" $ req & addJSON newMeeting - -getMeetingsList :: (HasCallStack, MakesValue user) => user -> App Response -getMeetingsList user = do - req <- baseRequest user Galley Versioned "/meetings/list" - submit "GET" req - -getMeeting :: (HasCallStack, MakesValue user) => user -> String -> String -> App Response -getMeeting user domain meetingId = do - req <- baseRequest user Galley Versioned (joinHttpPath ["meetings", domain, meetingId]) - submit "GET" req - -putMeeting :: (HasCallStack, MakesValue user) => user -> String -> String -> Aeson.Value -> App Response -putMeeting user domain meetingId updatedMeeting = do - req <- baseRequest user Galley Versioned (joinHttpPath ["meetings", domain, meetingId]) - submit "PUT" $ req & addJSON updatedMeeting - -deleteMeeting :: (HasCallStack, MakesValue user) => user -> String -> String -> App Response -deleteMeeting user domain meetingId = do - req <- baseRequest user Galley Versioned (joinHttpPath ["meetings", domain, meetingId]) - submit "DELETE" req - -postMeetingInvitation :: (HasCallStack, MakesValue user) => user -> String -> String -> Aeson.Value -> App Response -postMeetingInvitation user domain meetingId invitation = do - req <- baseRequest user Galley Versioned (joinHttpPath ["meetings", domain, meetingId, "invitations"]) - submit "POST" $ req & addJSON invitation - -deleteMeetingInvitation :: (HasCallStack, MakesValue user) => user -> String -> String -> Aeson.Value -> App Response -deleteMeetingInvitation user domain meetingId removeInvitation = do - req <- baseRequest user Galley Versioned (joinHttpPath ["meetings", domain, meetingId, "invitations", "delete"]) - submit "POST" $ req & addJSON removeInvitation - -putTeamFeature :: (HasCallStack, MakesValue user) => user -> String -> String -> Aeson.Value -> App Response -putTeamFeature user tid featureName payload = do - req <- baseRequest user Galley Unversioned (joinHttpPath ["i", "teams", tid, "features", featureName]) - submit "PUT" $ req & addJSON payload - --- Helper to create a default new meeting JSON object -defaultMeetingJson :: Text -> UTCTime -> UTCTime -> [Text] -> Aeson.Value -defaultMeetingJson title startTime endTime invitedEmails = - Aeson.object - [ "title" Aeson..= title, - "start_date" Aeson..= startTime, - "end_date" Aeson..= endTime, - "invited_emails" Aeson..= invitedEmails - ] - -- Helper to extract meetingId and domain from a meeting JSON object getMeetingIdAndDomain :: (HasCallStack) => Aeson.Value -> App (String, String) getMeetingIdAndDomain meeting = do @@ -498,3 +442,103 @@ testMeetingUpdateInvalidDates = do ] putMeeting owner domain meetingId updatedMeeting `shouldMatchStatus` 403 + +testMeetingUpdateInvalidDatesPartialEnd :: (HasCallStack) => App () +testMeetingUpdateInvalidDatesPartialEnd = do + (owner, _tid, _members) <- createTeam OwnDomain 1 + now <- liftIO getCurrentTime + let startTime = addUTCTime 3600 now + endTime = addUTCTime 7200 now + newMeeting = defaultMeetingJson "Valid Meeting" startTime endTime [] + + r1 <- postMeetings owner newMeeting + r1.status `shouldMatchInt` 201 + + meeting <- assertOne r1.jsonBody + (meetingId, domain) <- getMeetingIdAndDomain meeting + let updatedEndTimeInvalid = addUTCTime 1000 now -- endDate is before startDate + updatedMeeting = + Aeson.object + [ "end_date" Aeson..= updatedEndTimeInvalid + ] + + putMeeting owner domain meetingId updatedMeeting `shouldMatchStatus` 403 + +testMeetingUpdateInvalidDatesPartialStart :: (HasCallStack) => App () +testMeetingUpdateInvalidDatesPartialStart = do + (owner, _tid, _members) <- createTeam OwnDomain 1 + now <- liftIO getCurrentTime + let startTime = addUTCTime 3600 now + endTime = addUTCTime 7200 now + newMeeting = defaultMeetingJson "Valid Meeting" startTime endTime [] + + r1 <- postMeetings owner newMeeting + r1.status `shouldMatchInt` 201 + + meeting <- assertOne r1.jsonBody + (meetingId, domain) <- getMeetingIdAndDomain meeting + let updatedStartTimeInvalid = addUTCTime 8000 now -- startDate is after endDate + updatedMeeting = + Aeson.object + [ "start_date" Aeson..= updatedStartTimeInvalid + ] + + putMeeting owner domain meetingId updatedMeeting `shouldMatchStatus` 403 + +-- * Helpers + +shouldMatchStatus :: (HasCallStack) => App Response -> Int -> App () +shouldMatchStatus mkResp expectedStatus = do + resp <- mkResp + resp.status `shouldMatchInt` expectedStatus + +-- Custom API helper functions for meetings +postMeetings :: (HasCallStack, MakesValue user) => user -> Aeson.Value -> App Response +postMeetings user newMeeting = do + req <- baseRequest user Galley Versioned "/meetings" + submit "POST" $ req & addJSON newMeeting + +getMeetingsList :: (HasCallStack, MakesValue user) => user -> App Response +getMeetingsList user = do + req <- baseRequest user Galley Versioned "/meetings/list" + submit "GET" req + +getMeeting :: (HasCallStack, MakesValue user) => user -> String -> String -> App Response +getMeeting user domain meetingId = do + req <- baseRequest user Galley Versioned (joinHttpPath ["meetings", domain, meetingId]) + submit "GET" req + +putMeeting :: (HasCallStack, MakesValue user) => user -> String -> String -> Aeson.Value -> App Response +putMeeting user domain meetingId updatedMeeting = do + req <- baseRequest user Galley Versioned (joinHttpPath ["meetings", domain, meetingId]) + submit "PUT" $ req & addJSON updatedMeeting + +deleteMeeting :: (HasCallStack, MakesValue user) => user -> String -> String -> App Response +deleteMeeting user domain meetingId = do + req <- baseRequest user Galley Versioned (joinHttpPath ["meetings", domain, meetingId]) + submit "DELETE" req + +postMeetingInvitation :: (HasCallStack, MakesValue user) => user -> String -> String -> Aeson.Value -> App Response +postMeetingInvitation user domain meetingId invitation = do + req <- baseRequest user Galley Versioned (joinHttpPath ["meetings", domain, meetingId, "invitations"]) + submit "POST" $ req & addJSON invitation + +deleteMeetingInvitation :: (HasCallStack, MakesValue user) => user -> String -> String -> Aeson.Value -> App Response +deleteMeetingInvitation user domain meetingId removeInvitation = do + req <- baseRequest user Galley Versioned (joinHttpPath ["meetings", domain, meetingId, "invitations", "delete"]) + submit "POST" $ req & addJSON removeInvitation + +putTeamFeature :: (HasCallStack, MakesValue user) => user -> String -> String -> Aeson.Value -> App Response +putTeamFeature user tid featureName payload = do + req <- baseRequest user Galley Unversioned (joinHttpPath ["i", "teams", tid, "features", featureName]) + submit "PUT" $ req & addJSON payload + +-- Helper to create a default new meeting JSON object +defaultMeetingJson :: Text -> UTCTime -> UTCTime -> [Text] -> Aeson.Value +defaultMeetingJson title startTime endTime invitedEmails = + Aeson.object + [ "title" Aeson..= title, + "start_date" Aeson..= startTime, + "end_date" Aeson..= endTime, + "invited_emails" Aeson..= invitedEmails + ] diff --git a/libs/wire-subsystems/src/Wire/MeetingsSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/MeetingsSubsystem/Interpreter.hs index 6be87b8b05..499a3eb77b 100644 --- a/libs/wire-subsystems/src/Wire/MeetingsSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/MeetingsSubsystem/Interpreter.hs @@ -274,15 +274,14 @@ updateMeetingImpl zUser meetingId update = do when (isNothing update.title && isNothing update.startDate && isNothing update.endDate && isNothing update.recurrence) $ throwS @'InvalidOperation - case (update.startDate, update.endDate) of - (Just start, Just end) -> when (end <= start) $ throwS @'InvalidOperation - _ -> pure () - -- Get existing meeting maybeMeeting <- Store.getMeeting meetingId case maybeMeeting of Nothing -> pure Nothing - Just meeting -> + Just meeting -> do + when (fromMaybe meeting.startDate update.startDate >= fromMaybe meeting.endDate update.endDate) $ + throwS @'InvalidOperation + -- Check authorization (only creator can update) if meeting.creator /= tUntagged zUser then pure Nothing From 841e9c53d5433c1466d7d8675918a971b57b5dcb Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Tue, 16 Dec 2025 15:30:09 +0100 Subject: [PATCH 23/29] refactor(tests): use common status assertions --- integration/test/Test/Meetings.hs | 93 +++++++++++++++---------------- 1 file changed, 44 insertions(+), 49 deletions(-) diff --git a/integration/test/Test/Meetings.hs b/integration/test/Test/Meetings.hs index 83715524cf..e58c357fdf 100644 --- a/integration/test/Test/Meetings.hs +++ b/integration/test/Test/Meetings.hs @@ -26,7 +26,7 @@ testMeetingCreate = do newMeeting = defaultMeetingJson "Team Standup" startTime endTime ["alice@example.com", "bob@example.com"] resp <- postMeetings owner newMeeting - resp.status `shouldMatchInt` 201 + assertSuccess resp meeting <- assertOne resp.jsonBody meeting %. "title" `shouldMatchText` "Team Standup" @@ -41,10 +41,10 @@ testMeetingLists = do endTime = addUTCTime 7200 now newMeeting = defaultMeetingJson "Team Standup" startTime endTime [] - postMeetings owner newMeeting `shouldMatchStatus` 201 + postMeetings owner newMeeting >>= assertStatus 201 resp <- getMeetingsList owner - resp.status `shouldMatchInt` 200 + assertSuccess resp meetings <- resp.jsonBody & asList length (meetings :: [Value]) `shouldMatchInt` 1 @@ -58,13 +58,13 @@ testMeetingGet = do newMeeting = defaultMeetingJson "Team Standup" startTime endTime [] r1 <- postMeetings owner newMeeting - r1.status `shouldMatchInt` 201 + assertSuccess r1 meeting <- assertOne r1.jsonBody (meetingId, domain) <- getMeetingIdAndDomain meeting r2 <- getMeeting owner domain meetingId - r2.status `shouldMatchInt` 200 + assertSuccess r2 fetchedMeeting <- assertOne r2.jsonBody fetchedMeeting %. "title" `shouldMatchText` "Team Standup" @@ -74,7 +74,7 @@ testMeetingGetNotFound = do (owner, _tid, _members) <- createTeam OwnDomain 1 fakeMeetingId <- randomId - getMeeting owner "example.com" fakeMeetingId `shouldMatchStatus` 404 + getMeeting owner "example.com" fakeMeetingId >>= assertStatus 404 testMeetingUpdate :: (HasCallStack) => App () testMeetingUpdate = do @@ -99,7 +99,7 @@ testMeetingUpdate = do ] r1 <- postMeetings owner newMeeting - r1.status `shouldMatchInt` 201 + assertSuccess r1 meeting <- assertOne r1.jsonBody (meetingId, domain) <- getMeetingIdAndDomain meeting @@ -117,7 +117,7 @@ testMeetingUpdate = do ] r2 <- putMeeting owner domain meetingId updatedMeeting - r2.status `shouldMatchInt` 200 + assertSuccess r2 updated <- assertOne r2.jsonBody updated %. "title" `shouldMatchText` "Updated Standup" @@ -139,7 +139,7 @@ testMeetingUpdateNotFound = do "end_date" Aeson..= endTime ] - putMeeting owner "example.com" fakeMeetingId update `shouldMatchStatus` 404 + putMeeting owner "example.com" fakeMeetingId update >>= assertStatus 404 testMeetingUpdateUnauthorized :: (HasCallStack) => App () testMeetingUpdateUnauthorized = do @@ -151,7 +151,7 @@ testMeetingUpdateUnauthorized = do newMeeting = defaultMeetingJson "Team Standup" startTime endTime [] r1 <- postMeetings owner newMeeting - r1.status `shouldMatchInt` 201 + assertSuccess r1 meeting <- assertOne r1.jsonBody (meetingId, domain) <- getMeetingIdAndDomain meeting @@ -162,7 +162,7 @@ testMeetingUpdateUnauthorized = do "end_date" Aeson..= endTime ] - putMeeting otherUser domain meetingId update `shouldMatchStatus` 404 + putMeeting otherUser domain meetingId update >>= assertStatus 404 testMeetingDelete :: (HasCallStack) => App () testMeetingDelete = do @@ -187,21 +187,21 @@ testMeetingDelete = do ] r1 <- postMeetings owner newMeeting - r1.status `shouldMatchInt` 201 + assertSuccess r1 meeting <- assertOne r1.jsonBody (meetingId, domain) <- getMeetingIdAndDomain meeting - deleteMeeting owner domain meetingId `shouldMatchStatus` 200 + deleteMeeting owner domain meetingId >>= assertStatus 200 - getMeeting owner domain meetingId `shouldMatchStatus` 404 + getMeeting owner domain meetingId >>= assertStatus 404 testMeetingDeleteNotFound :: (HasCallStack) => App () testMeetingDeleteNotFound = do (owner, _tid, _members) <- createTeam OwnDomain 1 fakeMeetingId <- randomId - deleteMeeting owner "example.com" fakeMeetingId `shouldMatchStatus` 404 + deleteMeeting owner "example.com" fakeMeetingId >>= assertStatus 404 testMeetingDeleteUnauthorized :: (HasCallStack) => App () testMeetingDeleteUnauthorized = do @@ -213,12 +213,12 @@ testMeetingDeleteUnauthorized = do newMeeting = defaultMeetingJson "Team Standup" startTime endTime [] r1 <- postMeetings owner newMeeting - r1.status `shouldMatchInt` 201 + assertSuccess r1 meeting <- assertOne r1.jsonBody (meetingId, domain) <- getMeetingIdAndDomain meeting - deleteMeeting otherUser domain meetingId `shouldMatchStatus` 404 + deleteMeeting otherUser domain meetingId >>= assertStatus 404 testMeetingAddInvitation :: (HasCallStack) => App () testMeetingAddInvitation = do @@ -229,16 +229,16 @@ testMeetingAddInvitation = do newMeeting = defaultMeetingJson "Team Standup" startTime endTime ["alice@example.com"] r1 <- postMeetings owner newMeeting - r1.status `shouldMatchInt` 201 + assertSuccess r1 meeting <- assertOne r1.jsonBody (meetingId, domain) <- getMeetingIdAndDomain meeting let invitation = Aeson.object ["emails" Aeson..= ["bob@example.com" :: Text]] - postMeetingInvitation owner domain meetingId invitation `shouldMatchStatus` 200 + postMeetingInvitation owner domain meetingId invitation >>= assertStatus 200 r2 <- getMeeting owner domain meetingId - r2.status `shouldMatchInt` 200 + assertSuccess r2 updated <- assertOne r2.jsonBody updated %. "invited_emails" `shouldMatch` ["alice@example.com" :: Text, "bob@example.com"] @@ -249,7 +249,7 @@ testMeetingAddInvitationNotFound = do fakeMeetingId <- randomId let invitation = Aeson.object ["emails" Aeson..= ["bob@example.com" :: Text]] - postMeetingInvitation owner "example.com" fakeMeetingId invitation `shouldMatchStatus` 404 + postMeetingInvitation owner "example.com" fakeMeetingId invitation >>= assertStatus 404 testMeetingRemoveInvitation :: (HasCallStack) => App () testMeetingRemoveInvitation = do @@ -260,16 +260,16 @@ testMeetingRemoveInvitation = do newMeeting = defaultMeetingJson "Team Standup" startTime endTime ["alice@example.com", "bob@example.com"] r1 <- postMeetings owner newMeeting - r1.status `shouldMatchInt` 201 + assertSuccess r1 meeting <- assertOne r1.jsonBody (meetingId, domain) <- getMeetingIdAndDomain meeting let removeInvitation = Aeson.object ["emails" Aeson..= ["alice@example.com" :: Text]] - deleteMeetingInvitation owner domain meetingId removeInvitation `shouldMatchStatus` 200 + deleteMeetingInvitation owner domain meetingId removeInvitation >>= assertStatus 200 r2 <- getMeeting owner domain meetingId - r2.status `shouldMatchInt` 200 + assertSuccess r2 updated <- assertOne r2.jsonBody updated %. "invited_emails" `shouldMatch` ["bob@example.com" :: Text] @@ -280,7 +280,7 @@ testMeetingRemoveInvitationNotFound = do fakeMeetingId <- randomId let removeInvitation = Aeson.object ["emails" Aeson..= ["alice@example.com" :: Text]] - deleteMeetingInvitation owner "example.com" fakeMeetingId removeInvitation `shouldMatchStatus` 404 + deleteMeetingInvitation owner "example.com" fakeMeetingId removeInvitation >>= assertStatus 404 -- Test that personal (non-team) users create trial meetings testMeetingCreatePersonalUserTrial :: (HasCallStack) => App () @@ -292,7 +292,7 @@ testMeetingCreatePersonalUserTrial = do newMeeting = defaultMeetingJson "Personal Meeting" startTime endTime [] r <- postMeetings personalUser newMeeting - r.status `shouldMatchInt` 201 + assertSuccess r meeting <- assertOne r.jsonBody meeting %. "trial" `shouldMatch` True @@ -303,7 +303,7 @@ testMeetingCreateNonPayingTeamTrial = do (owner, tid, _members) <- createTeam OwnDomain 1 let teamId = tid - putTeamFeature owner teamId "meetingPremium" (Aeson.object ["status" Aeson..= ("disabled" :: Text)]) `shouldMatchStatus` 200 + putTeamFeature owner teamId "meetingPremium" (Aeson.object ["status" Aeson..= ("disabled" :: Text)]) >>= assertStatus 200 now <- liftIO getCurrentTime let startTime = addUTCTime 3600 now @@ -311,7 +311,7 @@ testMeetingCreateNonPayingTeamTrial = do newMeeting = defaultMeetingJson "Non-Paying Team Meeting" startTime endTime [] r <- postMeetings owner newMeeting - r.status `shouldMatchInt` 201 + assertSuccess r meeting <- assertOne r.jsonBody meeting %. "trial" `shouldMatch` True @@ -322,7 +322,7 @@ testMeetingCreatePayingTeamNonTrial = do (owner, tid, _members) <- createTeam OwnDomain 1 let firstMeeting = Aeson.object ["status" Aeson..= ("enabled" :: Text)] - putTeamFeature owner tid "meetingPremium" firstMeeting `shouldMatchStatus` 200 + putTeamFeature owner tid "meetingPremium" firstMeeting >>= assertStatus 200 now <- liftIO getCurrentTime let startTime = addUTCTime 3600 now @@ -330,7 +330,7 @@ testMeetingCreatePayingTeamNonTrial = do newMeeting = defaultMeetingJson "Paying Team Meeting" startTime endTime [] r <- postMeetings owner newMeeting - r.status `shouldMatchInt` 201 + assertSuccess r meeting <- assertOne r.jsonBody meeting %. "trial" `shouldMatch` False @@ -342,7 +342,7 @@ testMeetingConfigDisabledBlocksCreate = do -- Disable the MeetingConfig feature let firstMeeting = Aeson.object ["status" Aeson..= ("disabled" :: Text), "lockStatus" Aeson..= ("unlocked" :: Text)] - putTeamFeature owner tid "meeting" firstMeeting `shouldMatchStatus` 200 + putTeamFeature owner tid "meeting" firstMeeting >>= assertStatus 200 -- Try to create a meeting - should fail now <- liftIO getCurrentTime @@ -350,7 +350,7 @@ testMeetingConfigDisabledBlocksCreate = do endTime = addUTCTime 7200 now newMeeting = defaultMeetingJson "Team Standup" startTime endTime [] - postMeetings owner newMeeting `shouldMatchStatus` 403 + postMeetings owner newMeeting >>= assertStatus 403 -- Test that disabled MeetingConfig feature blocks meeting listing testMeetingConfigDisabledBlocksList :: (HasCallStack) => App () @@ -363,14 +363,14 @@ testMeetingConfigDisabledBlocksList = do endTime = addUTCTime 7200 now newMeeting = defaultMeetingJson "Team Standup" startTime endTime [] - postMeetings owner newMeeting `shouldMatchStatus` 201 + postMeetings owner newMeeting >>= assertStatus 201 -- Disable the MeetingConfig feature let updatedMeeting = Aeson.object ["status" Aeson..= ("disabled" :: Text), "lockStatus" Aeson..= ("unlocked" :: Text)] - putTeamFeature owner tid "meeting" updatedMeeting `shouldMatchStatus` 200 + putTeamFeature owner tid "meeting" updatedMeeting >>= assertStatus 200 -- Try to list meetings - should fail - getMeetingsList owner `shouldMatchStatus` 403 + getMeetingsList owner >>= assertStatus 403 testMeetingRecurrence :: (HasCallStack) => App () testMeetingRecurrence = do @@ -395,13 +395,13 @@ testMeetingRecurrence = do ] r1 <- postMeetings owner newMeeting - r1.status `shouldMatchInt` 201 + assertSuccess r1 meeting <- assertOne r1.jsonBody (meetingId, domain) <- getMeetingIdAndDomain meeting r2 <- getMeeting owner domain meetingId - r2.status `shouldMatchInt` 200 + assertSuccess r2 fetchedMeeting <- assertOne r2.jsonBody fetchedMeeting %. "title" `shouldMatchText` "Daily Standup with Recurrence" @@ -418,7 +418,7 @@ testMeetingCreateInvalidDates = do endTimeInvalid = addUTCTime 3500 now -- endDate is before startDate newMeetingInvalid = defaultMeetingJson "Invalid Date" startTime endTimeInvalid [] - postMeetings owner newMeetingInvalid `shouldMatchStatus` 403 + postMeetings owner newMeetingInvalid >>= assertStatus 403 testMeetingUpdateInvalidDates :: (HasCallStack) => App () testMeetingUpdateInvalidDates = do @@ -429,7 +429,7 @@ testMeetingUpdateInvalidDates = do newMeeting = defaultMeetingJson "Valid Meeting" startTime endTime [] r1 <- postMeetings owner newMeeting - r1.status `shouldMatchInt` 201 + assertSuccess r1 meeting <- assertOne r1.jsonBody (meetingId, domain) <- getMeetingIdAndDomain meeting @@ -441,7 +441,7 @@ testMeetingUpdateInvalidDates = do "end_date" Aeson..= updatedEndTimeInvalid ] - putMeeting owner domain meetingId updatedMeeting `shouldMatchStatus` 403 + putMeeting owner domain meetingId updatedMeeting >>= assertStatus 403 testMeetingUpdateInvalidDatesPartialEnd :: (HasCallStack) => App () testMeetingUpdateInvalidDatesPartialEnd = do @@ -452,7 +452,7 @@ testMeetingUpdateInvalidDatesPartialEnd = do newMeeting = defaultMeetingJson "Valid Meeting" startTime endTime [] r1 <- postMeetings owner newMeeting - r1.status `shouldMatchInt` 201 + assertSuccess r1 meeting <- assertOne r1.jsonBody (meetingId, domain) <- getMeetingIdAndDomain meeting @@ -462,7 +462,7 @@ testMeetingUpdateInvalidDatesPartialEnd = do [ "end_date" Aeson..= updatedEndTimeInvalid ] - putMeeting owner domain meetingId updatedMeeting `shouldMatchStatus` 403 + putMeeting owner domain meetingId updatedMeeting >>= assertStatus 403 testMeetingUpdateInvalidDatesPartialStart :: (HasCallStack) => App () testMeetingUpdateInvalidDatesPartialStart = do @@ -473,7 +473,7 @@ testMeetingUpdateInvalidDatesPartialStart = do newMeeting = defaultMeetingJson "Valid Meeting" startTime endTime [] r1 <- postMeetings owner newMeeting - r1.status `shouldMatchInt` 201 + assertSuccess r1 meeting <- assertOne r1.jsonBody (meetingId, domain) <- getMeetingIdAndDomain meeting @@ -483,15 +483,10 @@ testMeetingUpdateInvalidDatesPartialStart = do [ "start_date" Aeson..= updatedStartTimeInvalid ] - putMeeting owner domain meetingId updatedMeeting `shouldMatchStatus` 403 + putMeeting owner domain meetingId updatedMeeting >>= assertStatus 403 -- * Helpers -shouldMatchStatus :: (HasCallStack) => App Response -> Int -> App () -shouldMatchStatus mkResp expectedStatus = do - resp <- mkResp - resp.status `shouldMatchInt` expectedStatus - -- Custom API helper functions for meetings postMeetings :: (HasCallStack, MakesValue user) => user -> Aeson.Value -> App Response postMeetings user newMeeting = do From 84e6c4aba42cbbd7fde4eecbd1c98982f23de5f7 Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Tue, 16 Dec 2025 19:29:48 +0100 Subject: [PATCH 24/29] refactor: drop multi-qualified --- .../20251122120000-meetings.sql | 26 --------- .../20251213223355-create-meetings-table.sql | 6 +- .../wire-subsystems/src/Wire/MeetingsStore.hs | 4 +- .../src/Wire/MeetingsStore/Postgres.hs | 56 +++++++++---------- .../src/Wire/MeetingsSubsystem/Interpreter.hs | 4 +- postgres-schema.sql | 4 +- 6 files changed, 32 insertions(+), 68 deletions(-) delete mode 100644 libs/wire-subsystems/postgres-migrations/20251122120000-meetings.sql diff --git a/libs/wire-subsystems/postgres-migrations/20251122120000-meetings.sql b/libs/wire-subsystems/postgres-migrations/20251122120000-meetings.sql deleted file mode 100644 index c1ddfa8e55..0000000000 --- a/libs/wire-subsystems/postgres-migrations/20251122120000-meetings.sql +++ /dev/null @@ -1,26 +0,0 @@ --- Wire Meetings table --- Create meetings table for storing scheduled meetings - -CREATE TABLE IF NOT EXISTS meetings ( - id UUID NOT NULL, - domain TEXT NOT NULL, - title TEXT NOT NULL, - creator UUID NOT NULL, - creator_domain TEXT NOT NULL, - start_date TIMESTAMPTZ NOT NULL, - end_date TIMESTAMPTZ NOT NULL, - recurrence JSONB, - conversation_id UUID NOT NULL, - conversation_domain TEXT NOT NULL, - invited_emails TEXT[] DEFAULT '{}', - trial BOOLEAN DEFAULT FALSE, - created_at TIMESTAMPTZ DEFAULT NOW(), - updated_at TIMESTAMPTZ DEFAULT NOW(), - PRIMARY KEY (domain, id) -); - --- Indexes for common queries -CREATE INDEX IF NOT EXISTS idx_meetings_creator ON meetings(creator); -CREATE INDEX IF NOT EXISTS idx_meetings_conversation ON meetings(conversation_id, conversation_domain); -CREATE INDEX IF NOT EXISTS idx_meetings_start_date ON meetings(start_date); -CREATE INDEX IF NOT EXISTS idx_meetings_end_date ON meetings(end_date); diff --git a/libs/wire-subsystems/postgres-migrations/20251213223355-create-meetings-table.sql b/libs/wire-subsystems/postgres-migrations/20251213223355-create-meetings-table.sql index eceb8e8603..1697a3be19 100644 --- a/libs/wire-subsystems/postgres-migrations/20251213223355-create-meetings-table.sql +++ b/libs/wire-subsystems/postgres-migrations/20251213223355-create-meetings-table.sql @@ -26,7 +26,6 @@ CREATE TABLE IF NOT EXISTS meetings ( -- Meeting metadata title text NOT NULL, creator uuid NOT NULL, - creator_domain text NOT NULL, -- Scheduling information start_date timestamptz NOT NULL, @@ -35,7 +34,6 @@ CREATE TABLE IF NOT EXISTS meetings ( -- Associated conversation conversation_id uuid NOT NULL, - conversation_domain text NOT NULL, -- Invitations invited_emails text[] NOT NULL DEFAULT '{}', @@ -59,7 +57,7 @@ CREATE INDEX IF NOT EXISTS idx_meetings_creator -- Index for looking up meetings by conversation CREATE INDEX IF NOT EXISTS idx_meetings_conversation - ON meetings(conversation_domain, conversation_id); + ON meetings(domain, conversation_id); -- Index for cleanup queries (finding old meetings) CREATE INDEX IF NOT EXISTS idx_meetings_end_date @@ -92,12 +90,10 @@ COMMENT ON COLUMN meetings.id IS 'Unique meeting identifier (UUID)'; COMMENT ON COLUMN meetings.domain IS 'Federation domain for the meeting'; COMMENT ON COLUMN meetings.title IS 'Meeting title/subject'; COMMENT ON COLUMN meetings.creator IS 'User ID who created the meeting'; -COMMENT ON COLUMN meetings.creator_domain IS 'Domain of the user who created the meeting'; COMMENT ON COLUMN meetings.start_date IS 'Meeting start time'; COMMENT ON COLUMN meetings.end_date IS 'Meeting end time'; COMMENT ON COLUMN meetings.recurrence IS 'Optional recurring schedule information (JSON)'; COMMENT ON COLUMN meetings.conversation_id IS 'Associated conversation ID'; -COMMENT ON COLUMN meetings.conversation_domain IS 'Domain of the associated conversation'; COMMENT ON COLUMN meetings.invited_emails IS 'Array of email addresses invited to the meeting'; COMMENT ON COLUMN meetings.trial IS 'Whether this meeting is created under a trial account'; COMMENT ON COLUMN meetings.created_at IS 'Timestamp when the meeting was created'; diff --git a/libs/wire-subsystems/src/Wire/MeetingsStore.hs b/libs/wire-subsystems/src/Wire/MeetingsStore.hs index ceb3c6463b..44432ad2aa 100644 --- a/libs/wire-subsystems/src/Wire/MeetingsStore.hs +++ b/libs/wire-subsystems/src/Wire/MeetingsStore.hs @@ -30,12 +30,12 @@ import Wire.API.User.Identity (EmailAddress) data MeetingsStore m a where CreateMeeting :: Qualified MeetingId -> - Qualified UserId -> + UserId -> Text -> UTCTime -> UTCTime -> Maybe Recurrence -> - Qualified ConvId -> + ConvId -> [EmailAddress] -> Bool -> MeetingsStore m () diff --git a/libs/wire-subsystems/src/Wire/MeetingsStore/Postgres.hs b/libs/wire-subsystems/src/Wire/MeetingsStore/Postgres.hs index 91516a7b68..aeac06a5d3 100644 --- a/libs/wire-subsystems/src/Wire/MeetingsStore/Postgres.hs +++ b/libs/wire-subsystems/src/Wire/MeetingsStore/Postgres.hs @@ -78,16 +78,16 @@ createMeetingImpl :: Member (Error UsageError) r ) => Qualified MeetingId -> - Qualified UserId -> + UserId -> Text -> UTCTime -> UTCTime -> Maybe API.Recurrence -> - Qualified ConvId -> + ConvId -> [EmailAddress] -> Bool -> Sem r () -createMeetingImpl qMeetingId qCreator title startDate endDate recurrence qConvId emails trial = do +createMeetingImpl qMeetingId creator title startDate endDate recurrence convId emails trial = do pool <- input result <- liftIO $ use pool session either throw pure result @@ -96,29 +96,27 @@ createMeetingImpl qMeetingId qCreator title startDate endDate recurrence qConvId session = statement params insertStatement params = - ( idToText (qUnqualified qMeetingId), + ( toUUID (qUnqualified qMeetingId), _domainText (qDomain qMeetingId), title, - toUUID (qUnqualified qCreator), - _domainText (qDomain qCreator), + toUUID creator, startDate, endDate, fmap toJSON recurrence, - toUUID (qUnqualified qConvId), - _domainText (qDomain qConvId), + toUUID convId, V.fromList (map fromEmail emails), trial ) - insertStatement :: Statement (Text, Text, Text, UUID.UUID, Text, UTCTime, UTCTime, Maybe Value, UUID.UUID, Text, V.Vector Text, Bool) () + insertStatement :: Statement (UUID.UUID, Text, Text, UUID.UUID, UTCTime, UTCTime, Maybe Value, UUID.UUID, V.Vector Text, Bool) () insertStatement = [resultlessStatement| INSERT INTO meetings - (id, domain, title, creator, creator_domain, start_date, end_date, recurrence, - conversation_id, conversation_domain, invited_emails, trial) + (id, domain, title, creator, start_date, end_date, recurrence, + conversation_id, invited_emails, trial) VALUES - ($1 :: text :: uuid, $2 :: text, $3 :: text, $4 :: uuid, $5 :: text, $6 :: timestamptz, - $7 :: timestamptz, $8 :: jsonb?, $9 :: uuid, $10 :: text, $11 :: text[], $12 :: boolean) + ($1 :: uuid, $2 :: text, $3 :: text, $4 :: uuid, $5 :: timestamptz, + $6 :: timestamptz, $7 :: jsonb?, $8 :: uuid, $9 :: text[], $10 :: boolean) |] getMeetingImpl :: @@ -142,9 +140,9 @@ getMeetingImpl qMeetingId = do Imports.id (fmap rowToMeeting) $ [maybeStatement| - SELECT id :: text :: uuid, domain :: text, title :: text, creator :: uuid, creator_domain :: text, + SELECT id :: uuid, domain :: text, title :: text, creator :: uuid, start_date :: timestamptz, end_date :: timestamptz, recurrence :: jsonb?, - conversation_id :: uuid, conversation_domain :: text, + conversation_id :: uuid, invited_emails :: text[], trial :: boolean, updated_at :: timestamptz FROM meetings WHERE domain = ($1 :: text) AND id :: text = ($2 :: text) @@ -171,9 +169,9 @@ listMeetingsByUserImpl userId = do Imports.id (V.toList . fmap rowToMeeting) $ [vectorStatement| - SELECT id :: text :: uuid, domain :: text, title :: text, creator :: uuid, creator_domain :: text, + SELECT id :: uuid, domain :: text, title :: text, creator :: uuid, start_date :: timestamptz, end_date :: timestamptz, recurrence :: jsonb?, - conversation_id :: uuid, conversation_domain :: text, + conversation_id :: uuid, invited_emails :: text[], trial :: boolean, updated_at :: timestamptz FROM meetings WHERE creator = ($1 :: uuid) @@ -201,12 +199,12 @@ listMeetingsByConversationImpl qConvId = do Imports.id (V.toList . fmap rowToMeeting) $ [vectorStatement| - SELECT id :: text :: uuid, domain :: text, title :: text, creator :: uuid, creator_domain :: text, + SELECT id :: text :: uuid, domain :: text, title :: text, creator :: uuid, start_date :: timestamptz, end_date :: timestamptz, recurrence :: jsonb?, - conversation_id :: uuid, conversation_domain :: text, + conversation_id :: uuid, invited_emails :: text[], trial :: boolean, updated_at :: timestamptz FROM meetings - WHERE conversation_id = ($1 :: uuid) AND conversation_domain = ($2 :: text) + WHERE conversation_id = ($1 :: uuid) AND domain = ($2 :: text) ORDER BY start_date ASC |] @@ -257,9 +255,9 @@ updateMeetingImpl qMeetingId mTitle mStartDate mEndDate mRecurrence = do Imports.id (fmap rowToMeeting) $ [maybeStatement| - SELECT id :: text :: uuid, domain :: text, title :: text, creator :: uuid, creator_domain :: text, + SELECT id :: text :: uuid, domain :: text, title :: text, creator :: uuid, start_date :: timestamptz, end_date :: timestamptz, recurrence :: jsonb?, - conversation_id :: uuid, conversation_domain :: text, + conversation_id :: uuid, invited_emails :: text[], trial :: boolean, updated_at :: timestamptz FROM meetings WHERE domain = ($1 :: text) AND id :: text = ($2 :: text) @@ -359,9 +357,9 @@ getOldMeetingsImpl cutoffTime batchSize = do id (fmap rowToMeeting . V.toList) [vectorStatement| - SELECT id :: uuid, domain :: text, title :: text, creator :: uuid, creator_domain :: text, + SELECT id :: uuid, domain :: text, title :: text, creator :: uuid, start_date :: timestamptz, end_date :: timestamptz, recurrence :: jsonb?, - conversation_id :: uuid, conversation_domain :: text, + conversation_id :: uuid, invited_emails :: text[], trial :: bool, updated_at :: timestamptz FROM meetings WHERE end_date < ($1 :: timestamptz) @@ -393,17 +391,15 @@ deleteMeetingBatchImpl meetingIds = do -- Helper functions -rowToMeeting :: (UUID, Text, Text, UUID, Text, UTCTime, UTCTime, Maybe Value, UUID, Text, V.Vector Text, Bool, UTCTime) -> API.Meeting -rowToMeeting (meetingIdUUID, domainText_, titleText, creatorUUID, creatorDomainText, startDate', endDate', recurrenceJSON, convIdUUID, convDomainText, emailsVec, trial', updatedAt') = +rowToMeeting :: (UUID, Text, Text, UUID, UTCTime, UTCTime, Maybe Value, UUID, V.Vector Text, Bool, UTCTime) -> API.Meeting +rowToMeeting (meetingIdUUID, domainText_, titleText, creatorUUID, startDate', endDate', recurrenceJSON, convIdUUID, emailsVec, trial', updatedAt') = let meetingId' = Id meetingIdUUID domain' = Domain domainText_ qMeetingId = Qualified meetingId' domain' creator' = Id creatorUUID - creatorDomain' = Domain creatorDomainText - qCreator = Qualified creator' creatorDomain' + qCreator = Qualified creator' domain' convId' = Id convIdUUID - convDomain' = Domain convDomainText - qConvId = Qualified convId' convDomain' + qConvId = Qualified convId' domain' emails' = mapMaybe emailAddressText (V.toList emailsVec) recurrence' = recurrenceJSON >>= \v -> case fromJSON v of diff --git a/libs/wire-subsystems/src/Wire/MeetingsSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/MeetingsSubsystem/Interpreter.hs index 499a3eb77b..657379cd4e 100644 --- a/libs/wire-subsystems/src/Wire/MeetingsSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/MeetingsSubsystem/Interpreter.hs @@ -138,12 +138,12 @@ createMeetingImpl zUser newMeeting premium = do -- Store meeting (trial status is provided by caller) Store.createMeeting qMeetingId - (tUntagged zUser) + (tUnqualified zUser) newMeeting.title newMeeting.startDate newMeeting.endDate newMeeting.recurrence - qConvId + storedConv.id_ newMeeting.invitedEmails trial diff --git a/postgres-schema.sql b/postgres-schema.sql index 3c7663f64b..0b0843ac41 100644 --- a/postgres-schema.sql +++ b/postgres-schema.sql @@ -171,12 +171,10 @@ CREATE TABLE public.meetings ( domain text NOT NULL, title text NOT NULL, creator uuid NOT NULL, - creator_domain text NOT NULL, start_date timestamp with time zone NOT NULL, end_date timestamp with time zone NOT NULL, recurrence text, conversation_id uuid NOT NULL, - conversation_domain text NOT NULL, invited_emails text[] DEFAULT '{}'::text[], trial boolean DEFAULT false, created_at timestamp with time zone DEFAULT now(), @@ -449,7 +447,7 @@ CREATE INDEX conversation_team_idx ON public.conversation USING btree (team); -- Name: idx_meetings_conversation; Type: INDEX; Schema: public; Owner: wire-server -- -CREATE INDEX idx_meetings_conversation ON public.meetings USING btree (conversation_domain, conversation_id); +CREATE INDEX idx_meetings_conversation ON public.meetings USING btree (domain, conversation_id); -- From ff9aa664744d6a105fb11da0caef739b6c076556 Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Tue, 16 Dec 2025 20:54:54 +0100 Subject: [PATCH 25/29] fix: formatting --- .../ConversationSubsystem/Notification.hs | 8 +-- .../src/Wire/ConversationSubsystem/View.hs | 61 ++++++++++--------- .../MeetingsSubsystemCleaning/Interpreter.hs | 9 +-- 3 files changed, 40 insertions(+), 38 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Notification.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Notification.hs index 5eb32cd1d3..831fb213e0 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Notification.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Notification.hs @@ -10,8 +10,8 @@ import Data.Default import Data.Id import Data.Json.Util import Data.List.Extra (nubOrd) -import Data.List.NonEmpty qualified as NE import Data.List.NonEmpty (NonEmpty) +import Data.List.NonEmpty qualified as NE import Data.Qualified import Data.Set qualified as Set import Data.Singletons @@ -21,15 +21,15 @@ import Network.AMQP qualified as Q import Polysemy import Polysemy.Error import Polysemy.TinyLog qualified as P -import Wire.API.Component (Component(..)) +import Wire.API.Component (Component (..)) import Wire.API.Conversation hiding (Member, cnvAccess, cnvAccessRoles, cnvName, cnvType) import Wire.API.Conversation qualified as Public import Wire.API.Conversation.Action import Wire.API.Conversation.Protocol import Wire.API.Conversation.Role -import Wire.API.Error.Galley (UnreachableBackends(..)) +import Wire.API.Error.Galley (UnreachableBackends (..)) import Wire.API.Event.Conversation -import Wire.API.Federation.API (fedClient, sendBundle, makeConversationUpdateBundle) +import Wire.API.Federation.API (fedClient, makeConversationUpdateBundle, sendBundle) import Wire.API.Federation.API.Galley import Wire.API.Federation.Client (FederatorClient) import Wire.API.Federation.Error diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/View.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/View.hs index 9640f5e177..03be70b322 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/View.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/View.hs @@ -1,4 +1,5 @@ {-# LANGUAGE RecordWildCards #-} + module Wire.ConversationSubsystem.View where import Data.Domain (Domain) @@ -34,7 +35,7 @@ conversationView :: Maybe (Local UserId) -> StoredConversation -> Conversation -conversationView l luid conv = +conversationView l luid conv = let remoteMembers = map remoteMemberToOther $ conv.remoteMembers localMembers = map (localMemberToOther (tDomain l)) $ conv.localMembers selfs = filter (\m -> fmap tUnqualified luid == Just m.id_) (conv.localMembers) @@ -61,10 +62,10 @@ conversationViewWithCachedOthers remoteOthers localOthers conv luid = do maybe memberNotFound pure mbConv where memberNotFound = do - P.err . msg $ - val "User " + P.err . msg $ + val "User " +++ idToText (tUnqualified luid) - +++ val " is not a member of conv " + +++ val " is not a member of conv " +++ idToText conv.id_ throw BadMemberState @@ -73,54 +74,54 @@ conversationViewMaybe luid remoteOthers localOthers conv = do let selfs = filter (\m -> tUnqualified luid == m.id_) conv.localMembers self <- localMemberToSelf luid <$> listToMaybe selfs let others = filter (\oth -> tUntagged luid /= omQualifiedId oth) localOthers <> remoteOthers - pure $ - OwnConversation + pure $ + OwnConversation (tUntagged . qualifyAs luid $ conv.id_) - conv.metadata + conv.metadata (OwnConvMembers self others) conv.protocol -remoteConversationView :: - Local UserId -> - MemberStatus -> - Remote RemoteConversationV2 -> +remoteConversationView :: + Local UserId -> + MemberStatus -> + Remote RemoteConversationV2 -> OwnConversation -remoteConversationView uid status (tUntagged -> Qualified rconv rDomain) = +remoteConversationView uid status (tUntagged -> Qualified rconv rDomain) = let mems = rconv.members others = mems.others - self = - localMemberToSelf - uid - LocalMember + self = + localMemberToSelf + uid + LocalMember { id_ = tUnqualified uid, service = Nothing, status = status, convRoleName = mems.selfRole } - in OwnConversation + in OwnConversation (Qualified rconv.id rDomain) - rconv.metadata + rconv.metadata (OwnConvMembers self others) rconv.protocol -conversationToRemote :: - Domain -> - Remote UserId -> - StoredConversation -> +conversationToRemote :: + Domain -> + Remote UserId -> + StoredConversation -> Maybe RemoteConversationV2 conversationToRemote localDomain ruid conv = do let (selfs, rothers) = partition (\r -> r.id_ == ruid) (conv.remoteMembers) lothers = conv.localMembers selfRole' <- (.convRoleName) <$> listToMaybe selfs - let others' = - map (localMemberToOther localDomain) lothers + let others' = + map (localMemberToOther localDomain) lothers <> map remoteMemberToOther rothers - pure $ - RemoteConversationV2 + pure $ + RemoteConversationV2 { id = conv.id_, metadata = conv.metadata, - members = - RemoteConvMembers + members = + RemoteConvMembers { selfRole = selfRole', others = others' }, @@ -128,8 +129,8 @@ conversationToRemote localDomain ruid conv = do } localMemberToSelf :: Local x -> LocalMember -> Conversation.Member -localMemberToSelf loc lm = - Conversation.Member +localMemberToSelf loc lm = + Conversation.Member { memId = tUntagged . qualifyAs loc $ lm.id_, memService = lm.service, memOtrMutedStatus = msOtrMutedStatus st, diff --git a/libs/wire-subsystems/src/Wire/MeetingsSubsystemCleaning/Interpreter.hs b/libs/wire-subsystems/src/Wire/MeetingsSubsystemCleaning/Interpreter.hs index 783a2e634e..307deadc98 100644 --- a/libs/wire-subsystems/src/Wire/MeetingsSubsystemCleaning/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/MeetingsSubsystemCleaning/Interpreter.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE RecordWildCards #-} + -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2025 Wire Swiss GmbH @@ -24,11 +25,11 @@ import Data.Time.Clock (UTCTime) import Imports import Polysemy import Wire.API.Conversation (GroupConvType (MeetingConversation), cnvmGroupConvType) -import Wire.API.Meeting (Meeting(..)) +import Wire.API.Meeting (Meeting (..)) import Wire.ConversationStore qualified as ConvStore import Wire.MeetingsStore qualified as Store import Wire.MeetingsSubsystemCleaning -import Wire.StoredConversation (StoredConversation(..)) +import Wire.StoredConversation (StoredConversation (..)) interpretMeetingsSubsystemCleaning :: ( Member Store.MeetingsStore r, @@ -54,8 +55,8 @@ cleanupOldMeetingsImpl cutoffTime batchSize = do then pure 0 else do -- 2. Extract meeting IDs and conversation IDs - let meetingIds = map (\Meeting{id = mid} -> mid) oldMeetings - convIds = map (\Meeting{conversationId = cid} -> cid) oldMeetings + let meetingIds = map (\Meeting {id = mid} -> mid) oldMeetings + convIds = map (\Meeting {conversationId = cid} -> cid) oldMeetings -- 3. Delete meetings from database deletedCount <- Store.deleteMeetingBatch meetingIds From 0f74bc99a1c3dcd537097e15a0079572c7349393 Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Tue, 16 Dec 2025 23:52:05 +0100 Subject: [PATCH 26/29] fix: hlint --- integration/test/Test/Meetings.hs | 2 +- libs/wire-subsystems/src/Wire/ConversationSubsystem/View.hs | 2 -- libs/wire-subsystems/src/Wire/MeetingsSubsystem/Interpreter.hs | 2 -- .../src/Wire/MeetingsSubsystemCleaning/Interpreter.hs | 1 - 4 files changed, 1 insertion(+), 6 deletions(-) diff --git a/integration/test/Test/Meetings.hs b/integration/test/Test/Meetings.hs index e58c357fdf..a6689cbddd 100644 --- a/integration/test/Test/Meetings.hs +++ b/integration/test/Test/Meetings.hs @@ -14,7 +14,7 @@ getMeetingIdAndDomain :: (HasCallStack) => Aeson.Value -> App (String, String) getMeetingIdAndDomain meeting = do meetingId <- meeting %. "qualified_id" %. "id" >>= asString domain <- meeting %. "qualified_id" %. "domain" >>= asString - return (meetingId, domain) + pure (meetingId, domain) testMeetingCreate :: (HasCallStack) => App () testMeetingCreate = do diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/View.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/View.hs index 03be70b322..9141e49553 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/View.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/View.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE RecordWildCards #-} - module Wire.ConversationSubsystem.View where import Data.Domain (Domain) diff --git a/libs/wire-subsystems/src/Wire/MeetingsSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/MeetingsSubsystem/Interpreter.hs index 657379cd4e..564495746e 100644 --- a/libs/wire-subsystems/src/Wire/MeetingsSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/MeetingsSubsystem/Interpreter.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE RecordWildCards #-} - -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2025 Wire Swiss GmbH diff --git a/libs/wire-subsystems/src/Wire/MeetingsSubsystemCleaning/Interpreter.hs b/libs/wire-subsystems/src/Wire/MeetingsSubsystemCleaning/Interpreter.hs index 307deadc98..f0e034e80f 100644 --- a/libs/wire-subsystems/src/Wire/MeetingsSubsystemCleaning/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/MeetingsSubsystemCleaning/Interpreter.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE RecordWildCards #-} -- This file is part of the Wire Server implementation. -- From b4c06427e41284f9461a14e705fa5628e1b4809d Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Wed, 17 Dec 2025 21:49:12 +0100 Subject: [PATCH 27/29] feature(background-worker): use cron --- charts/background-worker/values.yaml | 6 +- integration/test/Test/Meetings.hs | 73 +++++++++++++++++++ .../background-worker/background-worker.cabal | 1 + .../background-worker.integration.yaml | 4 +- services/background-worker/default.nix | 2 + .../src/Wire/BackgroundWorker/Env.hs | 11 +++ .../src/Wire/BackgroundWorker/Options.hs | 23 +++++- .../src/Wire/MeetingsCleanupWorker.hs | 37 ++++------ .../Wire/BackendNotificationPusherSpec.hs | 2 + .../background-worker/test/Test/Wire/Util.hs | 1 + 10 files changed, 130 insertions(+), 30 deletions(-) diff --git a/charts/background-worker/values.yaml b/charts/background-worker/values.yaml index c9c9a656bc..d8eec6be7d 100644 --- a/charts/background-worker/values.yaml +++ b/charts/background-worker/values.yaml @@ -87,11 +87,11 @@ config: # Meetings cleanup configuration meetingsCleanup: # Delete meetings older than this many hours (48 hours = 2 days) - cleanOlderThanHours: 48 + cleanOlderThanHours: 48.0 # Maximum number of meetings to delete per batch batchSize: 1000 - # Frequency in seconds to run the cleanup job (3600 = 1 hour) - cleanFrequencySeconds: 3600 + # Cron schedule for the cleanup job (0 * * * * = every hour) + schedule: "0 * * * *" # Controls where conversation data is stored/accessed postgresMigration: diff --git a/integration/test/Test/Meetings.hs b/integration/test/Test/Meetings.hs index a6689cbddd..3707a11851 100644 --- a/integration/test/Test/Meetings.hs +++ b/integration/test/Test/Meetings.hs @@ -3,11 +3,17 @@ module Test.Meetings where +import Control.Concurrent (threadDelay) +import Control.Monad.Reader (ask) -- Explicitly import ask import Data.Aeson as Aeson import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text import Data.Time.Clock import SetupHelpers +import System.Timeout (timeout) -- New import import Testlib.Prelude as P +import Text.Regex.TDFA ((=~)) -- Helper to extract meetingId and domain from a meeting JSON object getMeetingIdAndDomain :: (HasCallStack) => Aeson.Value -> App (String, String) @@ -537,3 +543,70 @@ defaultMeetingJson title startTime endTime invitedEmails = "end_date" Aeson..= endTime, "invited_emails" Aeson..= invitedEmails ] + +testMeetingCleanup :: (HasCallStack) => App () +testMeetingCleanup = do + env <- ask + timedOutResult <- liftIO $ timeout (2 * 60 * 1_000_000) $ runAppWithEnv env $ do + -- 2 minutes timeout + (owner, _tid, _members) <- createTeam OwnDomain 1 + now <- liftIO getCurrentTime + -- Create a meeting that ends now. + -- Configured retention is 0.0014 hours (~5 seconds). + -- cutoffTime will be now' - 5s. + -- We need end_date < cutoffTime. + -- If we wait 6 seconds, now' = now + 6s. + -- cutoffTime = now + 6s - 5s = now + 1s. + -- end_date (now) < cutoffTime (now + 1s). + let startTime = addUTCTime (negate 3600) now + endTime = now + newMeeting = defaultMeetingJson "Cleanup Test" startTime endTime [] + + r1 <- postMeetings owner newMeeting + assertSuccess r1 + meeting <- assertOne r1.jsonBody + (meetingId, domain) <- getMeetingIdAndDomain meeting + + -- Wait 6 seconds to ensure meeting is old enough + liftIO $ threadDelay 6_000_000 + + -- Wait for cleanup job to run + waitForCleanupJob OwnDomain + + -- Check it's gone + getMeeting owner domain meetingId >>= assertStatus 404 + + case timedOutResult of + Just () -> pure () + Nothing -> assertFailure "testMeetingCleanup timed out after 2 minutes" + +waitForCleanupJob :: (HasCallStack, MakesValue domain) => domain -> App () +waitForCleanupJob domain = do + initialMetrics <- getMetricsBody domain + let initialCount = getRunCount initialMetrics + + waitForIncrease domain initialCount + where + getMetricsBody d = do + getMetrics d BackgroundWorker `bindResponse` \resp -> do + resp.status `shouldMatchInt` 200 + pure $ Text.decodeUtf8 resp.body + + getRunCount metrics = + let (_, _, _, matches) :: (Text, Text, Text, [Text]) = (metrics =~ Text.pack "wire_meetings_cleanup_runs_total ([0-9]+)") + in case matches of + [val] -> read (Text.unpack val) :: Int + _ -> 0 + + waitForIncrease d oldVal = do + metrics <- getMetricsBody d + let newVal = getRunCount metrics + -- We wait until it increases. + -- Note: if oldVal was 0 (metric didn't exist), getting 0 again means it hasn't run. + -- If it runs, it should become >= 1. + -- But wait, if matches is empty, we return 0. + -- If the metric appears, it will be >= 1 (initialized at 0? Counter starts at 0). + -- If it runs, it increments. + when (newVal <= oldVal) $ do + liftIO $ threadDelay 1_000_000 -- Wait 1s + waitForIncrease d oldVal diff --git a/services/background-worker/background-worker.cabal b/services/background-worker/background-worker.cabal index 6197716c94..6a107355ec 100644 --- a/services/background-worker/background-worker.cabal +++ b/services/background-worker/background-worker.cabal @@ -39,6 +39,7 @@ library , bytestring-conversion , cassandra-util , containers + , cron , data-timeout , exceptions , extended diff --git a/services/background-worker/background-worker.integration.yaml b/services/background-worker/background-worker.integration.yaml index 7f10b97c28..24bf447659 100644 --- a/services/background-worker/background-worker.integration.yaml +++ b/services/background-worker/background-worker.integration.yaml @@ -77,9 +77,9 @@ backgroundJobs: # Meetings cleanup configuration for integration meetingsCleanup: - cleanOlderThanHours: 24 # Clean meetings older than 24 hours (for testing) + cleanOlderThanHours: 0.0014 # Clean meetings older than ~5 seconds batchSize: 100 - cleanFrequencySeconds: 3600 # Run every hour + schedule: "* * * * *" # Run every minute postgresMigration: conversation: postgresql diff --git a/services/background-worker/default.nix b/services/background-worker/default.nix index bf38b5f423..654ebabb58 100644 --- a/services/background-worker/default.nix +++ b/services/background-worker/default.nix @@ -10,6 +10,7 @@ , bytestring-conversion , cassandra-util , containers +, cron , data-default , data-timeout , exceptions @@ -65,6 +66,7 @@ mkDerivation { bytestring-conversion cassandra-util containers + cron data-timeout exceptions extended diff --git a/services/background-worker/src/Wire/BackgroundWorker/Env.hs b/services/background-worker/src/Wire/BackgroundWorker/Env.hs index 11787f105c..856a886cda 100644 --- a/services/background-worker/src/Wire/BackgroundWorker/Env.hs +++ b/services/background-worker/src/Wire/BackgroundWorker/Env.hs @@ -70,6 +70,7 @@ data Env = Env httpManager :: Manager, defederationTimeout :: ResponseTimeout, backendNotificationMetrics :: BackendNotificationMetrics, + meetingsCleanupMetrics :: MeetingsCleanupMetrics, backendNotificationsConfig :: BackendNotificationsConfig, backgroundJobsConfig :: BackgroundJobsConfig, workerRunningGauge :: Vector Text Gauge, @@ -93,6 +94,10 @@ data BackendNotificationMetrics = BackendNotificationMetrics stuckQueuesGauge :: Vector Text Gauge } +data MeetingsCleanupMetrics = MeetingsCleanupMetrics + { runsCounter :: Counter + } + mkBackendNotificationMetrics :: IO BackendNotificationMetrics mkBackendNotificationMetrics = BackendNotificationMetrics @@ -100,6 +105,11 @@ mkBackendNotificationMetrics = <*> register (vector "targetDomain" $ counter $ Prometheus.Info "wire_backend_notifications_errors" "Number of errors that occurred while pushing notifications") <*> register (vector "targetDomain" $ gauge $ Prometheus.Info "wire_backend_notifications_stuck_queues" "Set to 1 when pushing notifications is stuck") +mkMeetingsCleanupMetrics :: IO MeetingsCleanupMetrics +mkMeetingsCleanupMetrics = + MeetingsCleanupMetrics + <$> register (counter $ Prometheus.Info "wire_meetings_cleanup_runs_total" "Number of times the meetings cleanup job has run") + mkWorkerRunningGauge :: IO (Vector Text Gauge) mkWorkerRunningGauge = register (vector "worker" $ gauge $ Prometheus.Info "wire_background_worker_running_workers" "Set to 1 when a worker is running") @@ -127,6 +137,7 @@ mkEnv opts = do (BackgroundJobConsumer, False) ] backendNotificationMetrics <- mkBackendNotificationMetrics + meetingsCleanupMetrics <- mkMeetingsCleanupMetrics let backendNotificationsConfig = opts.backendNotificationPusher backgroundJobsConfig = opts.backgroundJobs federationDomain = opts.federationDomain diff --git a/services/background-worker/src/Wire/BackgroundWorker/Options.hs b/services/background-worker/src/Wire/BackgroundWorker/Options.hs index 56ad1c2729..3e9fc66fb1 100644 --- a/services/background-worker/src/Wire/BackgroundWorker/Options.hs +++ b/services/background-worker/src/Wire/BackgroundWorker/Options.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE RecordWildCards #-} + -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2025 Wire Swiss GmbH @@ -18,6 +20,7 @@ module Wire.BackgroundWorker.Options where import Data.Aeson +import Data.Aeson.Types (JSONPathElement (Key), parserThrowError) import Data.Domain (Domain) import Data.Misc import Data.Range (Range) @@ -25,6 +28,7 @@ import GHC.Generics import Hasql.Pool.Extended import Imports import Network.AMQP.Extended +import System.Cron (CronSchedule, parseCronSchedule) import System.Logger.Extended import Util.Options import Wire.ConversationStore (PostgresMigrationOpts) @@ -99,11 +103,22 @@ data BackgroundJobsConfig = BackgroundJobsConfig data MeetingsCleanupConfig = MeetingsCleanupConfig { -- | Delete meetings older than this many hours - cleanOlderThanHours :: Int, + cleanOlderThanHours :: Double, -- | Maximum number of meetings to delete per batch batchSize :: Int, - -- | Frequency in seconds to run the cleanup job - cleanFrequencySeconds :: Int + -- | Cron schedule for the cleanup job + schedule :: CronSchedule } deriving (Show, Generic) - deriving (FromJSON) via Generically MeetingsCleanupConfig + +instance FromJSON MeetingsCleanupConfig where + parseJSON = + withObject "MeetingsCleanupConfig" $ \o -> do + cleanOlderThanHours <- o .: "cleanOlderThanHours" + batchSize <- o .: "batchSize" + scheduleRaw <- o .: "schedule" + schedule <- + case parseCronSchedule scheduleRaw of + Left e -> parserThrowError [Key "schedule"] $ "Cannot parse cronjob syntax: " <> e + Right x -> pure x + pure $ MeetingsCleanupConfig {..} diff --git a/services/background-worker/src/Wire/MeetingsCleanupWorker.hs b/services/background-worker/src/Wire/MeetingsCleanupWorker.hs index 050f0f5778..cbfe293962 100644 --- a/services/background-worker/src/Wire/MeetingsCleanupWorker.hs +++ b/services/background-worker/src/Wire/MeetingsCleanupWorker.hs @@ -29,9 +29,10 @@ import Imports import Polysemy import Polysemy.Error (runError) import Polysemy.Input (runInputConst) +import Prometheus (incCounter) +import System.Cron (Job (..), forkJob) import System.Logger qualified as Log -import UnliftIO (async) -import Wire.BackgroundWorker.Env (AppT, Env (..)) +import Wire.BackgroundWorker.Env (AppT, Env (..), MeetingsCleanupMetrics (..), runAppT) import Wire.BackgroundWorker.Options (MeetingsCleanupConfig (..)) import Wire.BackgroundWorker.Util (CleanupAction) import Wire.ConversationStore.Postgres (interpretConversationStoreToPostgres) @@ -40,7 +41,7 @@ import Wire.MeetingsSubsystemCleaning qualified as Meetings import Wire.MeetingsSubsystemCleaning.Interpreter (interpretMeetingsSubsystemCleaning) data CleanupConfig = CleanupConfig - { retentionHours :: Int, + { retentionHours :: Double, batchSize :: Int } deriving (Show, Eq) @@ -48,31 +49,25 @@ data CleanupConfig = CleanupConfig -- | Start the meetings cleanup worker thread -- -- This worker runs periodically to clean up old meetings based on the configuration. --- It sleeps for the configured frequency and then runs the cleanup operation. startWorker :: MeetingsCleanupConfig -> AppT IO CleanupAction startWorker config = do env <- ask - -- Start the worker loop in a separate thread - void . async $ workerLoop env config - -- Return a no-op cleanup action (worker will be killed when the process exits) - pure $ pure () - --- | Worker loop that runs periodically -workerLoop :: Env -> MeetingsCleanupConfig -> AppT IO () -workerLoop env config = forever $ do - -- Sleep for the configured frequency (convert seconds to microseconds) - liftIO $ threadDelay (config.cleanFrequencySeconds * 1_000_000) - Log.info env.logger $ - Log.msg (Log.val "Starting scheduled meetings cleanup") + Log.msg (Log.val "Starting meetings cleanup worker") + . Log.field "schedule" (show config.schedule) . Log.field "clean_older_than_hours" config.cleanOlderThanHours - . Log.field "batch_size" config.batchSize - . Log.field "frequency_seconds" config.cleanFrequencySeconds - -- Run the cleanup - cleanupOldMeetings (configFromOptions config) + void . liftIO $ do + forkJob $ + Job config.schedule $ + runAppT env $ do + Log.info env.logger $ Log.msg (Log.val "Starting scheduled meetings cleanup") + cleanupOldMeetings (configFromOptions config) + liftIO $ incCounter env.meetingsCleanupMetrics.runsCounter + + pure $ pure () -- | Convert MeetingsCleanupConfig to CleanupConfig configFromOptions :: MeetingsCleanupConfig -> CleanupConfig @@ -87,7 +82,7 @@ cleanupOldMeetings :: CleanupConfig -> AppT IO () cleanupOldMeetings config = do env <- ask now <- liftIO getCurrentTime - let cutoffTime = addUTCTime (negate $ fromIntegral config.retentionHours * 3600) now + let cutoffTime = addUTCTime (negate $ realToFrac config.retentionHours * 3600) now Log.info env.logger $ Log.msg (Log.val "Starting cleanup of old meetings") diff --git a/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs b/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs index 04307949b2..142b18ce61 100644 --- a/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs +++ b/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs @@ -366,6 +366,7 @@ spec = do brigEndpoint = undefined backendNotificationMetrics <- mkBackendNotificationMetrics + meetingsCleanupMetrics <- mkMeetingsCleanupMetrics workerRunningGauge <- mkWorkerRunningGauge domains <- runAppT Env {..} $ getRemoteDomains (fromJust rabbitmqAdminClient) domains `shouldBe` map Domain ["foo.example", "bar.example", "baz.example"] @@ -399,6 +400,7 @@ spec = do gundeckEndpoint = undefined brigEndpoint = undefined backendNotificationMetrics <- mkBackendNotificationMetrics + meetingsCleanupMetrics <- mkMeetingsCleanupMetrics workerRunningGauge <- mkWorkerRunningGauge domainsThread <- async $ runAppT Env {..} $ getRemoteDomains (fromJust rabbitmqAdminClient) diff --git a/services/background-worker/test/Test/Wire/Util.hs b/services/background-worker/test/Test/Wire/Util.hs index f7f24a54f0..306300c18d 100644 --- a/services/background-worker/test/Test/Wire/Util.hs +++ b/services/background-worker/test/Test/Wire/Util.hs @@ -42,6 +42,7 @@ testEnv = do postgresMigration = PostgresMigrationOpts CassandraStorage statuses <- newIORef mempty backendNotificationMetrics <- mkBackendNotificationMetrics + meetingsCleanupMetrics <- mkMeetingsCleanupMetrics workerRunningGauge <- mkWorkerRunningGauge httpManager <- newManager defaultManagerSettings let federatorInternal = Endpoint "localhost" 0 From eb048efea997e1d128754b1f497859e31661d5cb Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Thu, 18 Dec 2025 18:11:54 +0100 Subject: [PATCH 28/29] fix: queries exclude expired meetings --- charts/galley/templates/configmap.yaml | 6 + charts/galley/values.yaml | 3 + .../dockerephemeral/federation-v0/galley.yaml | 3 + .../dockerephemeral/federation-v1/galley.yaml | 3 + .../dockerephemeral/federation-v2/galley.yaml | 3 + integration/test/Test/Meetings.hs | 24 +++ .../wire-subsystems/src/Wire/MeetingsStore.hs | 2 + .../src/Wire/MeetingsStore/Postgres.hs | 26 +-- .../src/Wire/MeetingsSubsystem/Interpreter.hs | 198 +++++++++++------- services/galley/galley.integration.yaml | 3 + services/galley/src/Galley/App.hs | 4 +- services/galley/src/Galley/Options.hs | 14 +- 12 files changed, 197 insertions(+), 92 deletions(-) diff --git a/charts/galley/templates/configmap.yaml b/charts/galley/templates/configmap.yaml index 4d64c9f11f..db82700661 100644 --- a/charts/galley/templates/configmap.yaml +++ b/charts/galley/templates/configmap.yaml @@ -112,6 +112,12 @@ data: {{- if .settings.checkGroupInfo }} checkGroupInfo: {{ .settings.checkGroupInfo }} {{- end }} + {{- if .settings.meetings }} + meetings: + {{- if .settings.meetings.validityPeriodHours }} + validityPeriodHours: {{ .settings.meetings.validityPeriodHours }} + {{- end }} + {{- end }} featureFlags: sso: {{ .settings.featureFlags.sso }} legalhold: {{ .settings.featureFlags.legalhold }} diff --git a/charts/galley/values.yaml b/charts/galley/values.yaml index 8e328671d4..ce0635b8a6 100644 --- a/charts/galley/values.yaml +++ b/charts/galley/values.yaml @@ -120,6 +120,9 @@ config: checkGroupInfo: false + meetings: + validityPeriodHours: 48.0 + # To disable proteus for new federated conversations: # federationProtocols: ["mls"] diff --git a/deploy/dockerephemeral/federation-v0/galley.yaml b/deploy/dockerephemeral/federation-v0/galley.yaml index 5be62c125a..433b7d92d9 100644 --- a/deploy/dockerephemeral/federation-v0/galley.yaml +++ b/deploy/dockerephemeral/federation-v0/galley.yaml @@ -51,6 +51,9 @@ settings: removal: ed25519: /etc/wire/galley/conf/mls-private-key-ed25519.pem + meetings: + validityPeriodHours: 48.0 + featureFlags: # see #RefConfigOptions in `/docs/reference` sso: disabled-by-default legalhold: whitelist-teams-and-implicit-consent diff --git a/deploy/dockerephemeral/federation-v1/galley.yaml b/deploy/dockerephemeral/federation-v1/galley.yaml index d4a5070163..90d29268dc 100644 --- a/deploy/dockerephemeral/federation-v1/galley.yaml +++ b/deploy/dockerephemeral/federation-v1/galley.yaml @@ -53,6 +53,9 @@ settings: guestLinkTTLSeconds: 604800 disabledAPIVersions: [] + meetings: + validityPeriodHours: 48.0 + featureFlags: # see #RefConfigOptions in `/docs/reference` sso: disabled-by-default legalhold: whitelist-teams-and-implicit-consent diff --git a/deploy/dockerephemeral/federation-v2/galley.yaml b/deploy/dockerephemeral/federation-v2/galley.yaml index 4b8257f986..2a8b15a317 100644 --- a/deploy/dockerephemeral/federation-v2/galley.yaml +++ b/deploy/dockerephemeral/federation-v2/galley.yaml @@ -79,6 +79,9 @@ settings: disabledAPIVersions: [] + meetings: + validityPeriodHours: 48.0 + featureFlags: # see #RefConfigOptions in `/docs/reference` sso: disabled-by-default legalhold: whitelist-teams-and-implicit-consent diff --git a/integration/test/Test/Meetings.hs b/integration/test/Test/Meetings.hs index 3707a11851..3f860e3b3c 100644 --- a/integration/test/Test/Meetings.hs +++ b/integration/test/Test/Meetings.hs @@ -610,3 +610,27 @@ waitForCleanupJob domain = do when (newVal <= oldVal) $ do liftIO $ threadDelay 1_000_000 -- Wait 1s waitForIncrease d oldVal + +testMeetingExpiration :: (HasCallStack) => App () +testMeetingExpiration = do + (owner, _tid, _members) <- createTeam OwnDomain 1 + now <- liftIO getCurrentTime + let startTime = addUTCTime (negate 3600) now + -- meetingValidityPeriodSeconds is configured to 5 seconds in galley.integration.yaml + endTime = now + newMeeting = defaultMeetingJson "Expiring Meeting" startTime endTime [] + + r1 <- postMeetings owner newMeeting + assertSuccess r1 + meeting <- assertOne r1.jsonBody + (meetingId, domain) <- getMeetingIdAndDomain meeting + + -- Check it is accessible immediately (endDate = now, so valid until now + 5s) + getMeeting owner domain meetingId >>= assertStatus 200 + + -- Wait 6 seconds + liftIO $ threadDelay 6_000_000 + + -- Check it is expired + getMeeting owner domain meetingId >>= assertStatus 404 + diff --git a/libs/wire-subsystems/src/Wire/MeetingsStore.hs b/libs/wire-subsystems/src/Wire/MeetingsStore.hs index 44432ad2aa..599aeeacb4 100644 --- a/libs/wire-subsystems/src/Wire/MeetingsStore.hs +++ b/libs/wire-subsystems/src/Wire/MeetingsStore.hs @@ -44,9 +44,11 @@ data MeetingsStore m a where MeetingsStore m (Maybe Meeting) ListMeetingsByUser :: UserId -> + UTCTime -> MeetingsStore m [Meeting] ListMeetingsByConversation :: Qualified ConvId -> + UTCTime -> MeetingsStore m [Meeting] UpdateMeeting :: Qualified MeetingId -> diff --git a/libs/wire-subsystems/src/Wire/MeetingsStore/Postgres.hs b/libs/wire-subsystems/src/Wire/MeetingsStore/Postgres.hs index aeac06a5d3..9130ccd5dd 100644 --- a/libs/wire-subsystems/src/Wire/MeetingsStore/Postgres.hs +++ b/libs/wire-subsystems/src/Wire/MeetingsStore/Postgres.hs @@ -55,10 +55,10 @@ interpretMeetingsStoreToPostgres = createMeetingImpl meetingId creator title startDate endDate schedule convId emails trial GetMeeting meetingId -> getMeetingImpl meetingId - ListMeetingsByUser userId -> - listMeetingsByUserImpl userId - ListMeetingsByConversation convId -> - listMeetingsByConversationImpl convId + ListMeetingsByUser userId cutoffTime -> + listMeetingsByUserImpl userId cutoffTime + ListMeetingsByConversation convId cutoffTime -> + listMeetingsByConversationImpl convId cutoffTime UpdateMeeting meetingId title startDate endDate schedule -> updateMeetingImpl meetingId title startDate endDate schedule DeleteMeeting meetingId -> @@ -154,16 +154,17 @@ listMeetingsByUserImpl :: Member (Error UsageError) r ) => UserId -> + UTCTime -> Sem r [API.Meeting] -listMeetingsByUserImpl userId = do +listMeetingsByUserImpl userId cutoffTime = do pool <- input result <- liftIO $ use pool session either throw pure result where session :: Session [API.Meeting] - session = statement (toUUID userId) listStatement + session = statement (toUUID userId, cutoffTime) listStatement - listStatement :: Statement UUID.UUID [API.Meeting] + listStatement :: Statement (UUID.UUID, UTCTime) [API.Meeting] listStatement = dimap Imports.id @@ -174,7 +175,7 @@ listMeetingsByUserImpl userId = do conversation_id :: uuid, invited_emails :: text[], trial :: boolean, updated_at :: timestamptz FROM meetings - WHERE creator = ($1 :: uuid) + WHERE creator = ($1 :: uuid) AND end_date >= ($2 :: timestamptz) ORDER BY start_date ASC |] @@ -184,16 +185,17 @@ listMeetingsByConversationImpl :: Member (Error UsageError) r ) => Qualified ConvId -> + UTCTime -> Sem r [API.Meeting] -listMeetingsByConversationImpl qConvId = do +listMeetingsByConversationImpl qConvId cutoffTime = do pool <- input result <- liftIO $ use pool session either throw pure result where session :: Session [API.Meeting] - session = statement (toUUID (qUnqualified qConvId), _domainText (qDomain qConvId)) listStatement + session = statement (toUUID (qUnqualified qConvId), _domainText (qDomain qConvId), cutoffTime) listStatement - listStatement :: Statement (UUID.UUID, Text) [API.Meeting] + listStatement :: Statement (UUID.UUID, Text, UTCTime) [API.Meeting] listStatement = dimap Imports.id @@ -204,7 +206,7 @@ listMeetingsByConversationImpl qConvId = do conversation_id :: uuid, invited_emails :: text[], trial :: boolean, updated_at :: timestamptz FROM meetings - WHERE conversation_id = ($1 :: uuid) AND domain = ($2 :: text) + WHERE conversation_id = ($1 :: uuid) AND domain = ($2 :: text) AND end_date >= ($3 :: timestamptz) ORDER BY start_date ASC |] diff --git a/libs/wire-subsystems/src/Wire/MeetingsSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/MeetingsSubsystem/Interpreter.hs index 564495746e..1ee2d8c696 100644 --- a/libs/wire-subsystems/src/Wire/MeetingsSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/MeetingsSubsystem/Interpreter.hs @@ -22,7 +22,7 @@ import Data.Map qualified as Map import Data.Qualified import Data.Range (Range, unsafeRange) import Data.Set qualified as Set -import Data.Time.Clock (getCurrentTime) +import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, getCurrentTime) import Imports import Polysemy import Wire.API.Conversation hiding (Member) @@ -50,22 +50,23 @@ interpretMeetingsSubsystem :: Member (ErrorS 'NotATeamMember) r, Member (ErrorS 'InvalidOperation) r ) => + NominalDiffTime -> InterpreterFor MeetingsSubsystem r -interpretMeetingsSubsystem = interpret $ \case +interpretMeetingsSubsystem validityPeriod = interpret $ \case CreateMeeting zUser newMeeting premium -> createMeetingImpl zUser newMeeting premium GetMeeting zUser meetingId -> - getMeetingImpl zUser meetingId + getMeetingImpl zUser meetingId validityPeriod ListMeetings zUser -> - listMeetingsImpl zUser + listMeetingsImpl zUser validityPeriod UpdateMeeting zUser meetingId update -> - updateMeetingImpl zUser meetingId update + updateMeetingImpl zUser meetingId update validityPeriod DeleteMeeting zUser meetingId -> - deleteMeetingImpl zUser meetingId + deleteMeetingImpl zUser meetingId validityPeriod AddInvitedEmails zUser meetingId emails -> - addInvitedEmailsImpl zUser meetingId emails + addInvitedEmailsImpl zUser meetingId emails validityPeriod RemoveInvitedEmails zUser meetingId emails -> - removeInvitedEmailsImpl zUser meetingId emails + removeInvitedEmailsImpl zUser meetingId emails validityPeriod createMeetingImpl :: ( Member Store.MeetingsStore r, @@ -165,42 +166,54 @@ createMeetingImpl zUser newMeeting premium = do getMeetingImpl :: ( Member Store.MeetingsStore r, - Member ConvStore.ConversationStore r + Member ConvStore.ConversationStore r, + Member (Embed IO) r ) => Local UserId -> Qualified MeetingId -> + NominalDiffTime -> Sem r (Maybe API.Meeting) -getMeetingImpl zUser meetingId = do +getMeetingImpl zUser meetingId validityPeriod = do -- Get meeting from store maybeMeeting <- Store.getMeeting meetingId case maybeMeeting of Nothing -> pure Nothing Just meeting -> do - -- Check authorization: user must be creator OR member of the associated conversation - let isCreator = meeting.creator == tUntagged zUser - if isCreator - then pure (Just meeting) + now <- liftIO getCurrentTime + let cutoff = addUTCTime (negate validityPeriod) now + if meeting.endDate < cutoff + then pure Nothing else do - -- Check if user is a member of the conversation - let convId = qUnqualified meeting.conversationId - maybeMember <- ConvStore.getLocalMember convId (tUnqualified zUser) - case maybeMember of - Just _ -> pure (Just meeting) -- User is a member, authorized - Nothing -> pure Nothing -- User is not a member, not authorized + -- Check authorization: user must be creator OR member of the associated conversation + let isCreator = meeting.creator == tUntagged zUser + if isCreator + then pure (Just meeting) + else do + -- Check if user is a member of the conversation + let convId = qUnqualified meeting.conversationId + maybeMember <- ConvStore.getLocalMember convId (tUnqualified zUser) + case maybeMember of + Just _ -> pure (Just meeting) -- User is a member, authorized + Nothing -> pure Nothing -- User is not a member, not authorized listMeetingsImpl :: ( Member Store.MeetingsStore r, - Member ConvStore.ConversationStore r + Member ConvStore.ConversationStore r, + Member (Embed IO) r ) => Local UserId -> + NominalDiffTime -> Sem r [API.Meeting] -listMeetingsImpl zUser = do +listMeetingsImpl zUser validityPeriod = do + now <- liftIO getCurrentTime + let cutoff = addUTCTime (negate validityPeriod) now + -- List all meetings created by the user - createdMeetings <- Store.listMeetingsByUser (tUnqualified zUser) + createdMeetings <- Store.listMeetingsByUser (tUnqualified zUser) cutoff -- Loop over local conversations accessible by the user, then filter to only keep meetings. - memberMeetings <- getAllMemberMeetings zUser + memberMeetings <- getAllMemberMeetings zUser cutoff -- Combine and deduplicate let allMeetings = createdMeetings <> memberMeetings @@ -213,8 +226,9 @@ getAllMemberMeetings :: Member ConvStore.ConversationStore r ) => Local UserId -> + UTCTime -> Sem r [API.Meeting] -getAllMemberMeetings zUser = do +getAllMemberMeetings zUser cutoff = do -- We process conversations in pages processPage Nothing where @@ -245,7 +259,7 @@ getAllMemberMeetings zUser = do -- Fetch meetings for these conversations pageMeetings <- forM targetQConvIds $ \qConvId -> do - Store.listMeetingsByConversation qConvId + Store.listMeetingsByConversation qConvId cutoff let currentMeetings = concat pageMeetings @@ -262,13 +276,15 @@ getAllMemberMeetings zUser = do updateMeetingImpl :: ( Member Store.MeetingsStore r, - Member (ErrorS 'InvalidOperation) r + Member (ErrorS 'InvalidOperation) r, + Member (Embed IO) r ) => Local UserId -> Qualified MeetingId -> API.UpdateMeeting -> + NominalDiffTime -> Sem r (Maybe API.Meeting) -updateMeetingImpl zUser meetingId update = do +updateMeetingImpl zUser meetingId update validityPeriod = do when (isNothing update.title && isNothing update.startDate && isNothing update.endDate && isNothing update.recurrence) $ throwS @'InvalidOperation @@ -277,90 +293,116 @@ updateMeetingImpl zUser meetingId update = do case maybeMeeting of Nothing -> pure Nothing Just meeting -> do - when (fromMaybe meeting.startDate update.startDate >= fromMaybe meeting.endDate update.endDate) $ - throwS @'InvalidOperation - - -- Check authorization (only creator can update) - if meeting.creator /= tUntagged zUser + now <- liftIO getCurrentTime + let cutoff = addUTCTime (negate validityPeriod) now + if meeting.endDate < cutoff then pure Nothing - else - -- Update meeting - Store.updateMeeting - meetingId - update.title - update.startDate - update.endDate - update.recurrence + else do + when (fromMaybe meeting.startDate update.startDate >= fromMaybe meeting.endDate update.endDate) $ + throwS @'InvalidOperation + + -- Check authorization (only creator can update) + if meeting.creator /= tUntagged zUser + then pure Nothing + else + -- Update meeting + Store.updateMeeting + meetingId + update.title + update.startDate + update.endDate + update.recurrence deleteMeetingImpl :: ( Member Store.MeetingsStore r, - Member ConvStore.ConversationStore r + Member ConvStore.ConversationStore r, + Member (Embed IO) r ) => Local UserId -> Qualified MeetingId -> + NominalDiffTime -> Sem r Bool -deleteMeetingImpl zUser meetingId = do +deleteMeetingImpl zUser meetingId validityPeriod = do -- Get existing meeting maybeMeeting <- Store.getMeeting meetingId case maybeMeeting of Nothing -> pure False - Just meeting -> - -- Check authorization (only creator can delete) - if meeting.creator /= tUntagged zUser + Just meeting -> do + now <- liftIO getCurrentTime + let cutoff = addUTCTime (negate validityPeriod) now + if meeting.endDate < cutoff then pure False - else do - -- Delete meeting - Store.deleteMeeting meetingId - - -- Delete associated conversation if it's a meeting conversation - let convId = qUnqualified meeting.conversationId - maybeConv <- ConvStore.getConversation convId - case maybeConv of - Just conv - | conv.metadata.cnvmGroupConvType == Just MeetingConversation -> - ConvStore.deleteConversation convId - _ -> pure () - - pure True + else + -- Check authorization (only creator can delete) + if meeting.creator /= tUntagged zUser + then pure False + else do + -- Delete meeting + Store.deleteMeeting meetingId + + -- Delete associated conversation if it's a meeting conversation + let convId = qUnqualified meeting.conversationId + maybeConv <- ConvStore.getConversation convId + case maybeConv of + Just conv + | conv.metadata.cnvmGroupConvType == Just MeetingConversation -> + ConvStore.deleteConversation convId + _ -> pure () + + pure True addInvitedEmailsImpl :: - ( Member Store.MeetingsStore r + ( Member Store.MeetingsStore r, + Member (Embed IO) r ) => Local UserId -> Qualified MeetingId -> [EmailAddress] -> + NominalDiffTime -> Sem r Bool -addInvitedEmailsImpl zUser meetingId emails = do +addInvitedEmailsImpl zUser meetingId emails validityPeriod = do -- Get existing meeting maybeMeeting <- Store.getMeeting meetingId case maybeMeeting of Nothing -> pure False - Just meeting -> - -- Check authorization (only creator can add invitations) - if meeting.creator /= tUntagged zUser + Just meeting -> do + now <- liftIO getCurrentTime + let cutoff = addUTCTime (negate validityPeriod) now + if meeting.endDate < cutoff then pure False - else do - -- Add invited email - Store.addInvitedEmails meetingId emails - pure True + else + -- Check authorization (only creator can add invitations) + if meeting.creator /= tUntagged zUser + then pure False + else do + -- Add invited email + Store.addInvitedEmails meetingId emails + pure True removeInvitedEmailsImpl :: - ( Member Store.MeetingsStore r + ( Member Store.MeetingsStore r, + Member (Embed IO) r ) => Local UserId -> Qualified MeetingId -> [EmailAddress] -> + NominalDiffTime -> Sem r Bool -removeInvitedEmailsImpl zUser meetingId emails = do +removeInvitedEmailsImpl zUser meetingId emails validityPeriod = do -- Get existing meeting maybeMeeting <- Store.getMeeting meetingId case maybeMeeting of Nothing -> pure False - Just meeting -> - -- Check authorization (only creator can remove invitations) - if meeting.creator /= tUntagged zUser + Just meeting -> do + now <- liftIO getCurrentTime + let cutoff = addUTCTime (negate validityPeriod) now + if meeting.endDate < cutoff then pure False - else do - -- Remove invited email - Store.removeInvitedEmails meetingId emails - pure True + else + -- Check authorization (only creator can remove invitations) + if meeting.creator /= tUntagged zUser + then pure False + else do + -- Remove invited email + Store.removeInvitedEmails meetingId emails + pure True diff --git a/services/galley/galley.integration.yaml b/services/galley/galley.integration.yaml index 3170e3cee3..f3774e4c04 100644 --- a/services/galley/galley.integration.yaml +++ b/services/galley/galley.integration.yaml @@ -92,6 +92,9 @@ settings: - 127.0.0.1/8 maxRateLimitedKeys: 100000 # Estimated memory usage: 4 MB + meetings: + validityPeriodHours: 0.0014 + # We explicitly do not disable any API version. Please make sure the configuration value is the same in all these configs: # brig, cannon, cargohold, galley, gundeck, proxy, spar. disabledAPIVersions: [] diff --git a/services/galley/src/Galley/App.hs b/services/galley/src/Galley/App.hs index 79a2fb86af..5b1b2030c3 100644 --- a/services/galley/src/Galley/App.hs +++ b/services/galley/src/Galley/App.hs @@ -401,9 +401,11 @@ evalGalley e = . interpretSparAPIAccessToRpc (e ^. options . spar) . interpretTeamSubsystem teamSubsystemConfig . interpretConversationSubsystem - . interpretMeetingsSubsystem + . interpretMeetingsSubsystem meetingValidityPeriod . interpretTeamCollaboratorsSubsystem where + meetingValidityPeriod = + realToFrac $ fromMaybe 48.0 (e ^. options . settings . meetings >>= view validityPeriodHours) * 3600 lh = view (options . settings . featureFlags . to npProject) e legalHoldEnv = let makeReq fpr url rb = runApp e (LHInternal.makeVerifiedRequest fpr url rb) diff --git a/services/galley/src/Galley/Options.hs b/services/galley/src/Galley/Options.hs index a435707a7e..eba206c223 100644 --- a/services/galley/src/Galley/Options.hs +++ b/services/galley/src/Galley/Options.hs @@ -60,6 +60,8 @@ module Galley.Options passwordHashingOptions, passwordHashingRateLimit, checkGroupInfo, + meetings, + validityPeriodHours, postgresMigration, GuestLinkTTLSeconds (..), PostgresMigrationOpts (..), @@ -161,13 +163,23 @@ data Settings = Settings -- | Rate limiting options for hashing passwords (used for conversation codes) _passwordHashingRateLimit :: RateLimitConfig, -- | Check group info - _checkGroupInfo :: !(Maybe Bool) + _checkGroupInfo :: !(Maybe Bool), + -- | Configuration for meetings + _meetings :: !(Maybe MeetingsConfig) } deriving (Show, Generic) +data MeetingsConfig = MeetingsConfig + { -- | Validity period of a meeting in hours. After this time, the meeting is considered expired. + _validityPeriodHours :: !(Maybe Double) + } + deriving (Show, Generic) + +deriveFromJSON toOptionFieldName ''MeetingsConfig deriveFromJSON toOptionFieldName ''Settings makeLenses ''Settings +makeLenses ''MeetingsConfig defConcurrentDeletionEvents :: Int defConcurrentDeletionEvents = 128 From bb6636db85f4103f7ae76c5b44cc465f68986101 Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Thu, 18 Dec 2025 18:18:16 +0100 Subject: [PATCH 29/29] fix: formatting --- integration/test/Test/Meetings.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/integration/test/Test/Meetings.hs b/integration/test/Test/Meetings.hs index 3f860e3b3c..059e1cf37f 100644 --- a/integration/test/Test/Meetings.hs +++ b/integration/test/Test/Meetings.hs @@ -633,4 +633,3 @@ testMeetingExpiration = do -- Check it is expired getMeeting owner domain meetingId >>= assertStatus 404 -