diff --git a/charts/galley/templates/configmap.yaml b/charts/galley/templates/configmap.yaml index 57dc603a61..7754421916 100644 --- a/charts/galley/templates/configmap.yaml +++ b/charts/galley/templates/configmap.yaml @@ -112,6 +112,8 @@ data: {{- if .settings.checkGroupInfo }} checkGroupInfo: {{ .settings.checkGroupInfo }} {{- end }} + meetings: + {{- toYaml .settings.meetings | nindent 8 }} featureFlags: sso: {{ .settings.featureFlags.sso }} legalhold: {{ .settings.featureFlags.legalhold }} diff --git a/charts/galley/values.yaml b/charts/galley/values.yaml index 578b559ae5..a5693f3e3d 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/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/API/Galley.hs b/integration/test/API/Galley.hs index 391b162b77..d89922a7d7 100644 --- a/integration/test/API/Galley.hs +++ b/integration/test/API/Galley.hs @@ -961,3 +961,13 @@ searchChannels user tid args = do [("discoverable", "true") | args.discoverable] ] ) + +postMeetings :: (HasCallStack, MakesValue user) => user -> Value -> App Response +postMeetings user newMeeting = do + req <- baseRequest user Galley Versioned "/meetings" + submit "POST" $ req & addJSON newMeeting + +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 diff --git a/integration/test/Test/FeatureFlags/Util.hs b/integration/test/Test/FeatureFlags/Util.hs index 0f0cf79319..f7b5077ee9 100644 --- a/integration/test/Test/FeatureFlags/Util.hs +++ b/integration/test/Test/FeatureFlags/Util.hs @@ -254,6 +254,8 @@ hasExplicitLockStatus "sndFactorPasswordChallenge" = True hasExplicitLockStatus "outlookCalIntegration" = True hasExplicitLockStatus "enforceFileDownloadLocation" = True hasExplicitLockStatus "domainRegistration" = True +hasExplicitLockStatus "meetings" = True +hasExplicitLockStatus "meetingsPremium" = True hasExplicitLockStatus _ = False checkFeature :: (HasCallStack, MakesValue user, MakesValue tid) => String -> user -> tid -> Value -> App () diff --git a/integration/test/Test/Meetings.hs b/integration/test/Test/Meetings.hs new file mode 100644 index 0000000000..8c601c44c6 --- /dev/null +++ b/integration/test/Test/Meetings.hs @@ -0,0 +1,193 @@ +{-# OPTIONS_GHC -Wno-ambiguous-fields #-} + +module Test.Meetings where + +import API.Galley +import qualified API.GalleyInternal as I +import Data.Aeson as Aeson +import qualified Data.Aeson.Key as Key +import Data.Time.Clock +import qualified Data.Time.Format as Time +import SetupHelpers +import Testlib.Prelude as P hiding ((.=)) + +-- Helper to extract meetingId and domain from a meeting JSON object +getMeetingIdAndDomain :: (HasCallStack) => Value -> App (String, String) +getMeetingIdAndDomain meeting = do + meetingId <- meeting %. "qualified_id" %. "id" >>= asString + domain <- meeting %. "qualified_id" %. "domain" >>= asString + pure (meetingId, domain) + +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 = defaultMeetingJson "Team Standup" startTime endTime ["alice@example.com", "bob@example.com"] + + resp <- postMeetings owner newMeeting + assertSuccess resp + + meeting <- assertOne resp.jsonBody + meeting %. "title" `shouldMatch` "Team Standup" + meeting %. "qualified_creator" %. "id" `shouldMatch` ownerId + meeting %. "invited_emails" `shouldMatch` ["alice@example.com", "bob@example.com"] + +testMeetingGet :: (HasCallStack) => App () +testMeetingGet = do + (owner, _tid, _members) <- createTeam OwnDomain 1 + now <- liftIO getCurrentTime + let startTime = addUTCTime 3600 now + endTime = addUTCTime 7200 now + newMeeting = defaultMeetingJson "Team Standup" startTime endTime [] + + r1 <- postMeetings owner newMeeting + assertSuccess r1 + + meeting <- assertOne r1.jsonBody + (meetingId, domain) <- getMeetingIdAndDomain meeting + + r2 <- getMeeting owner domain meetingId + assertSuccess r2 + + fetchedMeeting <- assertOne r2.jsonBody + fetchedMeeting %. "title" `shouldMatch` "Team Standup" + +testMeetingGetNotFound :: (HasCallStack) => App () +testMeetingGetNotFound = do + (owner, _tid, _members) <- createTeam OwnDomain 1 + fakeMeetingId <- randomId + + getMeeting owner "example.com" fakeMeetingId >>= assertLabel 404 "meeting-not-found" + +-- 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 = defaultMeetingJson "Personal Meeting" startTime endTime [] + + r <- postMeetings personalUser newMeeting + assertSuccess r + + 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 + I.setTeamFeatureLockStatus owner tid "meetingsPremium" "unlocked" + setTeamFeatureConfig owner teamId "meetingsPremium" (Aeson.object [Key.fromString "status" .= Key.fromString "disabled"]) >>= assertStatus 200 + + now <- liftIO getCurrentTime + let startTime = addUTCTime 3600 now + endTime = addUTCTime 7200 now + newMeeting = defaultMeetingJson "Non-Paying Team Meeting" startTime endTime [] + + r <- postMeetings owner newMeeting + assertSuccess r + + 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 firstMeeting = Aeson.object [Key.fromString "status" .= Key.fromString "enabled"] + I.setTeamFeatureLockStatus owner tid "meetingsPremium" "unlocked" + setTeamFeatureConfig owner tid "meetingsPremium" firstMeeting >>= assertStatus 200 + + now <- liftIO getCurrentTime + let startTime = addUTCTime 3600 now + endTime = addUTCTime 7200 now + newMeeting = defaultMeetingJson "Paying Team Meeting" startTime endTime [] + + r <- postMeetings owner newMeeting + assertSuccess r + + meeting <- assertOne r.jsonBody + meeting %. "trial" `shouldMatch` False + +-- Test that disabled MeetingsConfig feature blocks creation +testMeetingsConfigDisabledBlocksCreate :: (HasCallStack) => App () +testMeetingsConfigDisabledBlocksCreate = do + (owner, tid, _members) <- createTeam OwnDomain 1 + + -- Disable the MeetingsConfig feature + let firstMeeting = Aeson.object [Key.fromString "status" .= Key.fromString "disabled", Key.fromString "lockStatus" .= Key.fromString "unlocked"] + setTeamFeatureConfig owner tid "meetings" firstMeeting >>= assertStatus 200 + + -- Try to create a meeting - should fail + now <- liftIO getCurrentTime + let startTime = addUTCTime 3600 now + endTime = addUTCTime 7200 now + newMeeting = defaultMeetingJson "Team Standup" startTime endTime [] + + postMeetings owner newMeeting >>= assertLabel 403 "invalid-op" + +testMeetingRecurrence :: (HasCallStack) => App () +testMeetingRecurrence = do + (owner, _tid, _members) <- createTeam OwnDomain 1 + now <- liftIO getCurrentTime + let startTime = addUTCTime 3600 now + endTime = addUTCTime 7200 now + recurrenceUntil = Time.formatTime Time.defaultTimeLocale "%FT%TZ" $ addUTCTime (30 * nominalDay) now -- format to avoid rounding expectation mismatch + recurrence = + Aeson.object + [ Key.fromString "frequency" .= Key.fromString "daily", + Key.fromString "interval" .= (1 :: Int), + Key.fromString "until" .= recurrenceUntil + ] + newMeeting = + Aeson.object + [ Key.fromString "title" .= Key.fromString "Daily Standup with Recurrence", + Key.fromString "start_time" .= startTime, + Key.fromString "end_time" .= endTime, + Key.fromString "recurrence" .= recurrence, + Key.fromString "invited_emails" .= ["charlie@example.com"] + ] + + r1 <- postMeetings owner newMeeting + assertSuccess r1 + + meeting <- assertOne r1.jsonBody + (meetingId, domain) <- getMeetingIdAndDomain meeting + + r2 <- getMeeting owner domain meetingId + assertSuccess r2 + + fetchedMeeting <- assertOne r2.jsonBody + fetchedMeeting %. "title" `shouldMatch` "Daily Standup with Recurrence" + recurrence' <- fetchedMeeting %. "recurrence" + recurrence' %. "frequency" `shouldMatch` "daily" + recurrence' %. "interval" `shouldMatchInt` 1 + recurrence' %. "until" `shouldMatch` recurrenceUntil + +testMeetingCreateInvalidTimes :: (HasCallStack) => App () +testMeetingCreateInvalidTimes = do + (owner, _tid, _members) <- createTeam OwnDomain 1 + now <- liftIO getCurrentTime + let startTime = addUTCTime 3600 now + endTimeInvalid = addUTCTime 3500 now -- endTime is before startTime + newMeetingInvalid = defaultMeetingJson "Invalid Time" startTime endTimeInvalid [] + + postMeetings owner newMeetingInvalid >>= assertLabel 403 "invalid-op" + +-- Helper to create a default new meeting JSON object +defaultMeetingJson :: String -> UTCTime -> UTCTime -> [String] -> Value +defaultMeetingJson title startTime endTime invitedEmails = + Aeson.object + [ Key.fromString "title" .= title, + Key.fromString "start_time" .= startTime, + Key.fromString "end_time" .= endTime, + Key.fromString "invited_emails" .= invitedEmails + ] 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/Conversation.hs b/libs/wire-api/src/Wire/API/Conversation.hs index d10ad9c6f0..1095c4227e 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..a05b053d6d --- /dev/null +++ b/libs/wire-api/src/Wire/API/Meeting.hs @@ -0,0 +1,184 @@ +-- 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.Id (ConvId, MeetingId, UserId) +import Data.Int qualified as DI +import Data.Json.Util (utcTimeSchema) +import Data.OpenApi qualified as S +import Data.Qualified (Qualified) +import Data.Schema +import Data.Time.Clock +import Deriving.Aeson +import Imports +import Wire.API.PostgresMarshall (PostgresMarshall (..), PostgresUnmarshall (..)) +import Wire.API.User.Identity (EmailAddress) +import Wire.Arbitrary (Arbitrary, GenericUniform (..)) + +-- | Core Meeting type +data Meeting = Meeting + { id :: Qualified MeetingId, + title :: Text, + creator :: Qualified UserId, + startTime :: UTCTime, + endTime :: UTCTime, + recurrence :: Maybe Recurrence, + conversationId :: Qualified ConvId, + invitedEmails :: [EmailAddress], + trial :: Bool, + createdAt :: UTCTime, + updatedAt :: UTCTime + } + 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 + <*> (.startTime) .= field "start_time" utcTimeSchema + <*> (.endTime) .= field "end_time" utcTimeSchema + <*> (.recurrence) .= maybe_ (optField "recurrence" schema) + <*> (.conversationId) .= field "qualified_conversation" schema + <*> (.invitedEmails) .= field "invited_emails" (array schema) + <*> (.trial) .= field "trial" schema + <*> (.createdAt) .= field "created_at" utcTimeSchema + <*> (.updatedAt) .= field "updated_at" utcTimeSchema + +-- | Request to create a new meeting +data NewMeeting = NewMeeting + { startTime :: UTCTime, + endTime :: 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 + { -- | The interval between occurrences, e.g., every 2 weeks for Weekly frequency with interval=2 + freq :: Frequency, + interval :: 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 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") $ + NewMeeting + <$> (.startTime) .= field "start_time" utcTimeSchema + <*> (.endTime) .= field "end_time" 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 + { startTime :: Maybe UTCTime, + endTime :: 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 + <$> (.startTime) .= maybe_ (optField "start_time" utcTimeSchema) + <*> (.endTime) .= maybe_ (optField "end_time" utcTimeSchema) + <*> (.title) .= maybe_ (optField "title" schema) + <*> (.recurrence) .= maybe_ (optField "recurrence" schema) + +instance ToSchema Recurrence where + schema = + objectWithDocModifier "Recurrence" (description ?~ "Recurrence pattern for meetings") $ + Recurrence + <$> (.freq) .= field "frequency" schema + <*> (.interval) .= (fromMaybe 1 <$> 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) + +instance PostgresMarshall (Maybe Recurrence) (Maybe Text, Maybe DI.Int32, Maybe UTCTime) where + postgresMarshall Nothing = (Nothing, Nothing, Nothing) + postgresMarshall (Just r) = + ( Just $ case r.freq of + Daily -> "daily" + Weekly -> "weekly" + Monthly -> "monthly" + Yearly -> "yearly", + Just (fromIntegral r.interval), + r.until + ) + +instance PostgresUnmarshall (Maybe Text, Maybe DI.Int32, Maybe UTCTime) (Maybe Recurrence) where + postgresUnmarshall (Nothing, _, _) = Right Nothing + postgresUnmarshall (Just f, Just i, u) = do + freq <- case f of + "daily" -> Right Daily + "weekly" -> Right Weekly + "monthly" -> Right Monthly + "yearly" -> Right Yearly + _ -> Left $ "Unknown frequency: " <> f + pure . Just $ + Recurrence + { freq = freq, + interval = fromIntegral i, + until = u + } + postgresUnmarshall (Just _, Nothing, _) = Left "Missing interval for recurrence" 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/Meetings.hs b/libs/wire-api/src/Wire/API/Routes/Public/Galley/Meetings.hs new file mode 100644 index 0000000000..2e00d2bbbb --- /dev/null +++ b/libs/wire-api/src/Wire/API/Routes/Public/Galley/Meetings.hs @@ -0,0 +1,54 @@ +-- 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 Data.Id (MeetingId) +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 + "get-meeting" + ( Summary "Get a single meeting by ID" + :> ZLocalUser + :> "meetings" + :> Capture "domain" Domain + :> Capture "id" MeetingId + :> CanThrow 'MeetingNotFound + :> Get '[JSON] Meeting + ) 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/20251213223355-create-meetings-table.sql b/libs/wire-subsystems/postgres-migrations/20251213223355-create-meetings-table.sql new file mode 100644 index 0000000000..4457aeacfc --- /dev/null +++ b/libs/wire-subsystems/postgres-migrations/20251213223355-create-meetings-table.sql @@ -0,0 +1,57 @@ +-- 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 ( + id uuid NOT NULL, + title text NOT NULL, + creator uuid NOT NULL, + start_time timestamptz NOT NULL, + end_time timestamptz NOT NULL, + recurrence_frequency text, + recurrence_interval integer, + recurrence_until timestamptz, + conversation_id uuid NOT NULL, + invited_emails text[] NOT NULL DEFAULT '{}', + trial boolean NOT NULL DEFAULT false, + created_at timestamptz NOT NULL DEFAULT NOW(), + updated_at timestamptz NOT NULL DEFAULT NOW(), + PRIMARY KEY (id), + CONSTRAINT meetings_valid_time_range CHECK (end_time > start_time), + CONSTRAINT meetings_title_not_empty CHECK (length(trim(title)) > 0), + CONSTRAINT meetings_title_length CHECK (length(title) <= 256) +); + +-- 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_id); + +-- Index for cleanup queries (finding old meetings) +CREATE INDEX IF NOT EXISTS idx_meetings_end_time + ON meetings(end_time); + +-- Index for querying meetings within a time range +CREATE INDEX IF NOT EXISTS idx_meetings_start_time + ON meetings(start_time); 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..831fb213e0 --- /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 (NonEmpty) +import Data.List.NonEmpty qualified as NE +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, makeConversationUpdateBundle, sendBundle) +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..9141e49553 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/View.hs @@ -0,0 +1,143 @@ +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/MeetingsStore.hs b/libs/wire-subsystems/src/Wire/MeetingsStore.hs new file mode 100644 index 0000000000..4393521922 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/MeetingsStore.hs @@ -0,0 +1,117 @@ +{-# 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.Time.Clock +import Data.UUID (UUID) +import Data.Vector (Vector) +import Data.Vector qualified as V +import Imports +import Polysemy +import Wire.API.Meeting (Recurrence (..)) +import Wire.API.PostgresMarshall +import Wire.API.User.EmailAddress (emailAddressText, fromEmail) +import Wire.API.User.Identity (EmailAddress) + +data StoredMeeting = StoredMeeting + { id :: MeetingId, + title :: Text, + creator :: UserId, + startTime :: UTCTime, + endTime :: UTCTime, + recurrence :: Maybe Recurrence, + conversationId :: ConvId, + invitedEmails :: [EmailAddress], + trial :: Bool, + createdAt :: UTCTime, + updatedAt :: UTCTime + } + deriving (Show, Eq) + +type StoredMeetingTuple = + ( UUID, -- id + Text, -- title + UUID, -- creator + UTCTime, -- start_time + UTCTime, -- end_time + Maybe Text, -- recurrence_frequency + Maybe Int32, -- recurrence_interval + Maybe UTCTime, -- recurrence_until + UUID, -- conversation_id + Data.Vector.Vector Text, -- invited_emails + Bool, -- trial + UTCTime, -- created_at + UTCTime -- updated_at + ) + +instance PostgresMarshall StoredMeeting StoredMeetingTuple where + postgresMarshall sm = + let (rf, ri, ru) = postgresMarshall sm.recurrence + in ( toUUID sm.id, + sm.title, + toUUID sm.creator, + sm.startTime, + sm.endTime, + rf, + ri, + ru, + toUUID sm.conversationId, + V.fromList (map fromEmail sm.invitedEmails), + sm.trial, + sm.createdAt, + sm.updatedAt + ) + +instance PostgresUnmarshall StoredMeetingTuple StoredMeeting where + postgresUnmarshall (i, t, c, st, et, rf, ri, ru, ci, ie, tr, ca, ua) = do + rec' <- postgresUnmarshall (rf, ri, ru) + pure + StoredMeeting + { id = Id i, + title = t, + creator = Id c, + startTime = st, + endTime = et, + recurrence = rec', + conversationId = Id ci, + invitedEmails = mapMaybe emailAddressText (V.toList ie), + trial = tr, + createdAt = ca, + updatedAt = ua + } + +data MeetingsStore m a where + CreateMeeting :: + MeetingId -> + Text -> + UserId -> + UTCTime -> + UTCTime -> + Maybe Recurrence -> + ConvId -> + [EmailAddress] -> + Bool -> + MeetingsStore m StoredMeeting + GetMeeting :: + MeetingId -> + MeetingsStore m (Maybe StoredMeeting) + +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..36a3969248 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/MeetingsStore/Postgres.hs @@ -0,0 +1,138 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeApplications #-} + +-- 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.Id +import Data.Profunctor (dimap) +import Data.Time.Clock +import Data.UUID (UUID) +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 (Recurrence) +import Wire.API.PostgresMarshall (PostgresMarshall (..), PostgresUnmarshall (..)) +import Wire.API.User.Identity (EmailAddress) +import Wire.MeetingsStore + +interpretMeetingsStoreToPostgres :: + ( Member (Embed IO) r, + Member (Input Pool) r, + Member (Error UsageError) r + ) => + InterpreterFor MeetingsStore r +interpretMeetingsStoreToPostgres = + interpret $ \case + CreateMeeting meetingId title creator startTime endTime recurrence convId emails trial -> + createMeetingImpl meetingId title creator startTime endTime recurrence convId emails trial + GetMeeting meetingId -> + getMeetingImpl meetingId + +createMeetingImpl :: + ( Member (Input Pool) r, + Member (Embed IO) r, + Member (Error UsageError) r + ) => + MeetingId -> + Text -> + UserId -> + UTCTime -> + UTCTime -> + Maybe Recurrence -> + ConvId -> + [EmailAddress] -> + Bool -> + Sem r StoredMeeting +createMeetingImpl meetingId title creator startTime endTime recurrence convId emails trial = do + pool <- input + now <- liftIO getCurrentTime + let sm = + StoredMeeting + { id = meetingId, + title = title, + creator = creator, + startTime = startTime, + endTime = endTime, + recurrence = recurrence, + conversationId = convId, + invitedEmails = emails, + trial = trial, + createdAt = now, + updatedAt = now + } + result <- liftIO $ use pool $ statement sm insertStatement + either throw pure result + +insertStatement :: Statement StoredMeeting StoredMeeting +insertStatement = + dimap (postgresMarshall @StoredMeeting @StoredMeetingTuple) Imports.id $ + refineResult + (postgresUnmarshall @StoredMeetingTuple @StoredMeeting) + [singletonStatement| + INSERT INTO meetings + (id, title, creator, start_time, end_time, + recurrence_frequency, recurrence_interval, recurrence_until, + conversation_id, invited_emails, trial, created_at, updated_at) + VALUES + ($1 :: uuid, $2 :: text, $3 :: uuid, $4 :: timestamptz, $5 :: timestamptz, + $6 :: text?, $7 :: int4?, $8 :: timestamptz?, + $9 :: uuid, $10 :: text[], $11 :: boolean, $12 :: timestamptz, $13 :: timestamptz) + RETURNING + id :: uuid, title :: text, creator :: uuid, + start_time :: timestamptz, end_time :: timestamptz, + recurrence_frequency :: text?, recurrence_interval :: int4?, recurrence_until :: timestamptz?, + conversation_id :: uuid, invited_emails :: text[], trial :: boolean, + created_at :: timestamptz, updated_at :: timestamptz + |] + +getMeetingImpl :: + ( Member (Input Pool) r, + Member (Embed IO) r, + Member (Error UsageError) r + ) => + MeetingId -> + Sem r (Maybe StoredMeeting) +getMeetingImpl meetingId = do + pool <- input + result <- liftIO $ use pool $ statement (toUUID meetingId) getMeetingStatement + either throw pure result + +getMeetingStatement :: Statement UUID (Maybe StoredMeeting) +getMeetingStatement = + refineResult + (traverse (postgresUnmarshall @StoredMeetingTuple @StoredMeeting)) + [maybeStatement| + SELECT + id :: uuid, title :: text, creator :: uuid, + start_time :: timestamptz, end_time :: timestamptz, + recurrence_frequency :: text?, recurrence_interval :: int4?, recurrence_until :: timestamptz?, + conversation_id :: uuid, invited_emails :: text[], trial :: boolean, + created_at :: timestamptz, updated_at :: timestamptz + FROM meetings + WHERE id = $1 :: uuid + |] diff --git a/libs/wire-subsystems/src/Wire/MeetingsSubsystem.hs b/libs/wire-subsystems/src/Wire/MeetingsSubsystem.hs new file mode 100644 index 0000000000..6e806dc3ca --- /dev/null +++ b/libs/wire-subsystems/src/Wire/MeetingsSubsystem.hs @@ -0,0 +1,41 @@ +{-# 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 Imports +import Polysemy +import Wire.API.Meeting +import Wire.StoredConversation (StoredConversation) + +data MeetingsSubsystem m a where + CreateMeeting :: + Local UserId -> + NewMeeting -> + -- | premium: True if this is a premium meeting + Bool -> + MeetingsSubsystem m (Meeting, StoredConversation) + GetMeeting :: + Local UserId -> + Qualified MeetingId -> + MeetingsSubsystem m (Maybe Meeting) + +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..3a81b2c2e7 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/MeetingsSubsystem/Interpreter.hs @@ -0,0 +1,189 @@ +-- 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.Domain (Domain) +import Data.Id +import Data.Qualified (Local, Qualified (..), qualifyAs, tDomain, tUnqualified) +import Data.Set qualified as Set +import Data.Time.Clock (NominalDiffTime, addUTCTime, 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.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.ConversationStore qualified as ConvStore +import Wire.MeetingsStore qualified as Store +import Wire.MeetingsSubsystem +import Wire.StoredConversation +import Wire.TeamStore qualified as TeamStore +import Wire.UserList + +interpretMeetingsSubsystem :: + ( Member Store.MeetingsStore r, + Member ConvStore.ConversationStore r, + Member TeamStore.TeamStore r, + Member (Embed IO) r, + Member (ErrorS 'NotATeamMember) r, + Member (ErrorS 'InvalidOperation) r + ) => + NominalDiffTime -> + InterpreterFor MeetingsSubsystem r +interpretMeetingsSubsystem validityPeriod = interpret $ \case + CreateMeeting zUser newMeeting premium -> + createMeetingImpl zUser newMeeting premium + GetMeeting zUser meetingId -> + getMeetingImpl zUser meetingId validityPeriod + +createMeetingImpl :: + ( Member Store.MeetingsStore r, + Member ConvStore.ConversationStore r, + Member TeamStore.TeamStore r, + Member (Embed IO) r, + Member (ErrorS 'NotATeamMember) r, + Member (ErrorS 'InvalidOperation) r + ) => + Local UserId -> + API.NewMeeting -> + Bool -> + Sem r (API.Meeting, StoredConversation) +createMeetingImpl zUser newMeeting premium = do + -- Validate that endTime > startTime + when (newMeeting.endTime <= newMeeting.startTime) $ + 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 + + -- 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.fromList [TeamMemberAccessRole, NonTeamMemberAccessRole], + 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 + + -- Store meeting (trial status is provided by caller) + storedMeeting <- + Store.createMeeting + meetingId + newMeeting.title + (tUnqualified zUser) + newMeeting.startTime + newMeeting.endTime + newMeeting.recurrence + storedConv.id_ + newMeeting.invitedEmails + trial + + -- Return created meeting + pure + ( storedMeetingToMeeting (tDomain zUser) storedMeeting, + storedConv + ) + +getMeetingImpl :: + ( Member Store.MeetingsStore r, + Member ConvStore.ConversationStore r, + Member (Embed IO) r + ) => + Local UserId -> + Qualified MeetingId -> + NominalDiffTime -> + Sem r (Maybe API.Meeting) +getMeetingImpl zUser meetingId validityPeriod = do + -- Get meeting from store + maybeStoredMeeting <- Store.getMeeting (qUnqualified meetingId) + + case maybeStoredMeeting of + Nothing -> pure Nothing + Just storedMeeting -> do + now <- liftIO getCurrentTime + let cutoff = addUTCTime (negate validityPeriod) now + if storedMeeting.endTime < cutoff + then pure Nothing + else do + -- Check authorization: user must be creator OR member of the associated conversation + let isCreator = storedMeeting.creator == tUnqualified zUser + if isCreator + then pure (Just (storedMeetingToMeeting (tDomain zUser) storedMeeting)) + else do + -- Check if user is a member of the conversation + let convId = storedMeeting.conversationId + maybeMember <- ConvStore.getLocalMember convId (tUnqualified zUser) + case maybeMember of + Just _ -> pure (Just (storedMeetingToMeeting (tDomain zUser) storedMeeting)) -- User is a member, authorized + Nothing -> pure Nothing -- User is not a member, not authorized + +-- Helper function to convert StoredMeeting to API.Meeting +storedMeetingToMeeting :: Domain -> Store.StoredMeeting -> API.Meeting +storedMeetingToMeeting domain sm = + API.Meeting + { API.id = Qualified sm.id domain, + API.title = sm.title, + API.creator = Qualified sm.creator domain, + API.startTime = sm.startTime, + API.endTime = sm.endTime, + API.recurrence = sm.recurrence, + API.conversationId = Qualified sm.conversationId domain, + API.invitedEmails = sm.invitedEmails, + API.trial = sm.trial, + API.createdAt = sm.createdAt, + API.updatedAt = sm.updatedAt + } diff --git a/libs/wire-subsystems/wire-subsystems.cabal b/libs/wire-subsystems/wire-subsystems.cabal index f8ea7fdff6..566ec6e340 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 @@ -272,6 +274,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..c15938d696 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, + title text NOT NULL, + creator uuid NOT NULL, + start_time timestamp with time zone NOT NULL, + end_time timestamp with time zone NOT NULL, + recurrence_frequency text, + recurrence_interval integer, + recurrence_until timestamptz, + conversation_id uuid 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 (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); + + +-- +-- 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_time; Type: INDEX; Schema: public; Owner: wire-server +-- + +CREATE INDEX idx_meetings_end_time ON public.meetings USING btree (end_time); + + +-- +-- Name: idx_meetings_start_time; Type: INDEX; Schema: public; Owner: wire-server +-- + +CREATE INDEX idx_meetings_start_time ON public.meetings USING btree (start_time); + + -- -- Name: user_group_member_user_id_idx; Type: INDEX; Schema: public; Owner: wire-server -- diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index 8f8d45f27d..e0a9f5154b 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 diff --git a/services/galley/galley.integration.yaml b/services/galley/galley.integration.yaml index 6d6369ff3d..397003ecd0 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/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/Meetings.hs b/services/galley/src/Galley/API/Meetings.hs new file mode 100644 index 0000000000..4dfe7c6128 --- /dev/null +++ b/services/galley/src/Galley/API/Meetings.hs @@ -0,0 +1,129 @@ +-- 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, + ) +where + +import Data.Domain (Domain) +import Data.Id +import Data.Qualified +import Galley.API.Error +import Galley.API.Teams.Features.Get (getFeatureForTeam) +import Galley.Effects.TeamFeatureStore +import Galley.Options (Opts) +import Imports +import Polysemy +import Polysemy.Error (Error, runError, throw) +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 (..), MeetingsConfig, MeetingsPremiumConfig) +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) +import Wire.TeamStore qualified as TeamStore + +-- | Check if meetings feature is enabled for the user (if they're in a team) +checkMeetingsEnabled :: + ( Member TeamStore.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 @MeetingsConfig teamId + unless (meetingFeature.status == FeatureStatusEnabled) $ + throwS @'InvalidOperation + +createMeeting :: + ( Member Meetings.MeetingsSubsystem r, + Member (ErrorS 'InvalidOperation) 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.TeamStore r, + Member TeamFeatureStore r, + Member (Input Opts) r + ) => + Local UserId -> + NewMeeting -> + Sem r Meeting +createMeeting lUser newMeeting = do + -- Check if meetings feature is enabled + checkMeetingsEnabled (tUnqualified lUser) + + maybeTeamId <- TeamStore.getOneUserTeam (tUnqualified lUser) + premium <- case maybeTeamId of + Nothing -> pure True -- Personal users create trial meetings + Just teamId -> do + premiumFeature <- getFeatureForTeam @MeetingsPremiumConfig 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.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 + Nothing -> throwS @'MeetingNotFound + Just meeting -> pure meeting 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..71bd0e8d6a --- /dev/null +++ b/services/galley/src/Galley/API/Public/Meetings.hs @@ -0,0 +1,28 @@ +-- 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 @"get-meeting" Meetings.getMeeting 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/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 488d692aa7..08cfed3843 100644 --- a/services/galley/src/Galley/App.hs +++ b/services/galley/src/Galley/App.hs @@ -119,8 +119,11 @@ 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.Postgres (PGConstraints) import Wire.ProposalStore.Cassandra import Wire.RateLimit import Wire.RateLimit.Interpreter @@ -282,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) @@ -340,6 +353,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 +388,7 @@ evalGalley e = . interpretProposalStoreToCassandra . interpretCodeStoreToCassandra . interpretClientStoreToCassandra + . interpretMeetingsStoreToPostgres . interpretTeamCollaboratorsStoreToPostgres . interpretFireAndForget . BackendNotificationQueueAccess.interpretBackendNotificationQueueAccess backendNotificationQueueAccessEnv @@ -385,8 +401,11 @@ evalGalley e = . interpretSparAPIAccessToRpc (e ^. options . spar) . interpretTeamSubsystem teamSubsystemConfig . interpretConversationSubsystem + . 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/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/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