diff --git a/charts/background-worker/templates/configmap.yaml b/charts/background-worker/templates/configmap.yaml index 6c84d808767..fbcdd9dd702 100644 --- a/charts/background-worker/templates/configmap.yaml +++ b/charts/background-worker/templates/configmap.yaml @@ -25,6 +25,12 @@ data: host: brig port: 8080 + {{- if .enableFederation }} + federator: + host: {{ .federator.host }} + port: {{ .federator.port }} + {{- end }} + gundeck: host: gundeck port: 8080 @@ -103,4 +109,4 @@ data: {{- if .postgresMigration }} postgresMigration: {{- toYaml .postgresMigration | nindent 6 }} {{- end }} - {{- end }} + {{- end }} \ No newline at end of file diff --git a/charts/background-worker/values.yaml b/charts/background-worker/values.yaml index 2896d749e89..37f6c30d9dc 100644 --- a/charts/background-worker/values.yaml +++ b/charts/background-worker/values.yaml @@ -19,6 +19,9 @@ config: logLevel: Info logFormat: StructuredJSON enableFederation: false # keep in sync with brig, cargohold and galley charts' config.enableFederation as well as wire-server chart's tags.federation + federator: + host: federator + port: 8080 rabbitmq: host: rabbitmq port: 5672 diff --git a/charts/galley/templates/configmap.yaml b/charts/galley/templates/configmap.yaml index 57dc603a61c..77544219168 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 f4ac3331c59..ed79553d2db 100644 --- a/charts/galley/values.yaml +++ b/charts/galley/values.yaml @@ -121,6 +121,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 fae812e6f52..7efbdb358c6 100644 --- a/integration/integration.cabal +++ b/integration/integration.cabal @@ -172,6 +172,7 @@ library Test.Federator Test.LegalHold Test.Login + Test.Meetings Test.MessageTimer Test.Migration.Conversation Test.Migration.ConversationCodes diff --git a/integration/test/API/Galley.hs b/integration/test/API/Galley.hs index 391b162b776..d89922a7d79 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 ce2acde064a..54e177c4124 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 00000000000..8c601c44c61 --- /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/galley-types/default.nix b/libs/galley-types/default.nix index 4edd7e398d8..ff5a59d4968 100644 --- a/libs/galley-types/default.nix +++ b/libs/galley-types/default.nix @@ -12,6 +12,7 @@ , data-default , errors , gitignoreSource +, http-types , imports , lens , lib @@ -21,6 +22,7 @@ , types-common , utf8-string , uuid +, wai-utilities , wire-api }: mkDerivation { @@ -36,6 +38,7 @@ mkDerivation { crypton data-default errors + http-types imports lens memory @@ -44,6 +47,7 @@ mkDerivation { types-common utf8-string uuid + wai-utilities wire-api ]; license = lib.licenses.agpl3Only; diff --git a/libs/galley-types/galley-types.cabal b/libs/galley-types/galley-types.cabal index 3405710cad3..249cb27489e 100644 --- a/libs/galley-types/galley-types.cabal +++ b/libs/galley-types/galley-types.cabal @@ -16,6 +16,7 @@ library Galley.Types Galley.Types.Conversations.One2One Galley.Types.Conversations.Roles + Galley.Types.Error Galley.Types.Teams other-modules: Paths_galley_types @@ -76,6 +77,7 @@ library , crypton , data-default , errors + , http-types , imports , lens >=4.12 , memory @@ -84,6 +86,7 @@ library , types-common >=0.16 , utf8-string , uuid + , wai-utilities , wire-api default-language: GHC2021 diff --git a/services/galley/src/Galley/API/Error.hs b/libs/galley-types/src/Galley/Types/Error.hs similarity index 99% rename from services/galley/src/Galley/API/Error.hs rename to libs/galley-types/src/Galley/Types/Error.hs index a8241afa1c4..51a7223c868 100644 --- a/services/galley/src/Galley/API/Error.hs +++ b/libs/galley-types/src/Galley/Types/Error.hs @@ -18,7 +18,7 @@ -- | Most of the errors thrown by galley are defined as static errors in -- 'Wire.API.Error.Galley' and declared as part of the API. Errors defined here -- are dynamic, and mostly internal. -module Galley.API.Error +module Galley.Types.Error ( -- * Internal errors InvalidInput (..), InternalError (..), diff --git a/libs/types-common/src/Data/Id.hs b/libs/types-common/src/Data/Id.hs index ce636dae328..ba6e6c21d2c 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 ff83fd26029..7cc0a477c0e 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 Int32 ReceiptMode 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 540f6391cbb..198ac6060b0 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 00000000000..1f67f115152 --- /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 Text, Maybe DI.Int32, Maybe UTCTime) (Maybe Recurrence) 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 e7610068772..d7ab4e3c84b 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 00000000000..2e00d2bbbb2 --- /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 cc4ec01bb57..f8ef0bf898d 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 00000000000..4457aeacfcb --- /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.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs index ca068239bde..a84b8a2a98a 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs @@ -43,5 +43,10 @@ data ConversationSubsystem m a where ConversationAction (tag :: ConversationActionTag) -> ExtraConversationData -> ConversationSubsystem r LocalConversationUpdate + CreateConversation :: + Local ConvId -> + Local UserId -> + NewConversation -> + ConversationSubsystem m StoredConversation makeSem ''ConversationSubsystem diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs index 089e6d14c76..2b364a6b184 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs @@ -1,3 +1,17 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} + -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2025 Wire Swiss GmbH @@ -17,33 +31,58 @@ module Wire.ConversationSubsystem.Interpreter where +import Data.Bifunctor (second) import Data.Default import Data.Id -import Data.Json.Util (ToJSONObject (toJSONObject)) +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.Singletons (Sing) +import Data.Set qualified as Set +import Data.Singletons (Sing, sing) +import Data.Text qualified as T +import Data.Text.Lazy qualified as LT +import Data.Time (UTCTime) +import Galley.Types.Error qualified as GalleyError import Galley.Types.Teams (FeatureDefaults) import Imports import Network.AMQP qualified as Q import Polysemy import Polysemy.Error -import Wire.API.Conversation hiding (Member) +import Polysemy.TinyLog (TinyLog) +import Polysemy.TinyLog qualified as P +import System.Logger.Message (msg, val, (+++)) +import Wire.API.Component (Component (Brig, Galley)) +import Wire.API.Conversation qualified as Public import Wire.API.Conversation.Action -import Wire.API.Conversation.CellsState (CellsState (..)) -import Wire.API.Conversation.Protocol (ProtocolTag) +import Wire.API.Conversation.CellsState +import Wire.API.Conversation.Protocol (Protocol (ProtocolProteus), ProtocolTag) +import Wire.API.Conversation.Role +import Wire.API.Error.Galley import Wire.API.Event.Conversation -import Wire.API.Federation.API (makeConversationUpdateBundle, sendBundle) +import Wire.API.Federation.API (fedClient, makeConversationUpdateBundle, sendBundle) +import Wire.API.Federation.API.Galley (ConversationCreated (..), ccRemoteOrigUserId) import Wire.API.Federation.API.Galley.Notifications (ConversationUpdate (..)) -import Wire.API.Federation.Error (FederationError) +import Wire.API.Federation.Client (FederatorClient) +import Wire.API.Federation.Error import Wire.API.MLS.Keys (MLSKeysByPurpose, MLSPrivateKeys) -import Wire.API.Team.Feature (LegalholdConfig) -import Wire.BackendNotificationQueueAccess (BackendNotificationQueueAccess, enqueueNotificationsConcurrently) +import Wire.API.Push.V2 qualified as PushV2 +import Wire.API.Team.Feature +import Wire.BackendNotificationQueueAccess (BackendNotificationQueueAccess, enqueueNotificationsConcurrently, enqueueNotificationsConcurrentlyBuckets) +import Wire.ConversationStore (ConversationStore) +import Wire.ConversationStore qualified as ConvStore import Wire.ConversationSubsystem +import Wire.ConversationSubsystem.View (ViewError, conversationViewWithCachedOthers) import Wire.ExternalAccess (ExternalAccess, deliverAsync) +import Wire.FederationAPIAccess (FederationAPIAccess, runFederatedConcurrentlyEither) +import Wire.FederationAPIAccess qualified as E import Wire.NotificationSubsystem as NS import Wire.Sem.Now (Now) import Wire.Sem.Now qualified as Now -import Wire.StoredConversation +import Wire.StoredConversation hiding (convTeam, id_, localOne2OneConvId) +import Wire.StoredConversation as Data (LocalMember (..), NewConversation (..), RemoteMember (..), convType) +import Wire.StoredConversation qualified as Data data ConversationSubsystemConfig = ConversationSubsystemConfig { mlsKeys :: Maybe (MLSKeysByPurpose MLSPrivateKeys), @@ -54,16 +93,72 @@ data ConversationSubsystemConfig = ConversationSubsystemConfig interpretConversationSubsystem :: ( Member (Error FederationError) r, + Member (Error GalleyError.InternalError) r, Member BackendNotificationQueueAccess r, Member NotificationSubsystem r, Member ExternalAccess r, - Member Now r + Member Now r, + Member (Embed IO) r, + Member ConversationStore r, + Member (FederationAPIAccess FederatorClient) r, + Member TinyLog r ) => Sem (ConversationSubsystem : r) a -> Sem r a interpretConversationSubsystem = interpret $ \case NotifyConversationAction tag quid notifyOrigDomain con lconv targetsLocal targetsRemote targetsBots action extraData -> notifyConversationActionImpl tag quid notifyOrigDomain con lconv targetsLocal targetsRemote targetsBots action extraData + CreateConversation lconv lusr newConv -> do + res <- runError @UnreachableBackends $ runError @ViewError $ createConversationImpl lconv lusr newConv + case res of + Left (unreachable :: UnreachableBackends) -> throw $ FederationUnexpectedError (T.pack $ show unreachable) + Right (Left (viewErr :: ViewError)) -> throw $ GalleyError.InternalErrorWithDescription (LT.pack $ show viewErr) + Right (Right val') -> pure val' + +createConversationImpl :: + ( Member (Error FederationError) r, + Member (Error UnreachableBackends) r, + Member (Error ViewError) r, + Member BackendNotificationQueueAccess r, + Member NotificationSubsystem r, + Member Now r, + Member (Embed IO) r, + Member ConversationStore r, + Member (FederationAPIAccess FederatorClient) r, + Member TinyLog r + ) => + Local ConvId -> + Local UserId -> + Data.NewConversation -> + Sem r StoredConversation +createConversationImpl lconv lusr newConv = do + storedConv <- ConvStore.upsertConversation lconv newConv + notifyCreatedConversation lusr Nothing storedConv def + sendCellsNotification lusr Nothing storedConv + pure storedConv + +sendCellsNotification :: + ( Member NotificationSubsystem r, + Member Now r + ) => + Local UserId -> + Maybe ConnId -> + StoredConversation -> + Sem r () +sendCellsNotification lusr conn conv = do + now <- Now.get + let lconv = qualifyAs lusr conv.id_ + event = CellsEvent (tUntagged lconv) (tUntagged lusr) now CellsConvCreateNoData + when (conv.metadata.cnvmCellsState /= CellsDisabled) $ do + let push = + def + { origin = Just (tUnqualified lusr), + json = toJSONObject event, + isCellsEvent = True, + route = PushV2.RouteAny, + conn + } + NS.pushNotifications [push] notifyConversationActionImpl :: forall tag r. @@ -82,7 +177,7 @@ notifyConversationActionImpl :: Set (Remote UserId) -> Set BotMember -> ConversationAction (tag :: ConversationActionTag) -> - ExtraConversationData -> + Public.ExtraConversationData -> Sem r LocalConversationUpdate notifyConversationActionImpl tag eventFrom notifyOrigDomain con lconv targetsLocal targetsRemote targetsBots action extraData = do now <- Now.get @@ -127,7 +222,7 @@ pushConversationEvent :: f BotMember -> Sem r () pushConversationEvent conn st e lusers bots = do - pushNotifications [(newConversationEventPush (fmap toList lusers)) {conn}] + NS.pushNotifications [(newConversationEventPush (fmap toList lusers)) {conn}] deliverAsync (map (,e) (toList bots)) where newConversationEventPush :: Local [UserId] -> Push @@ -137,6 +232,231 @@ pushConversationEvent conn st e lusers bots = do in def { origin = musr, json = toJSONObject e, - recipients = map userRecipient (tUnqualified users), + recipients = map NS.userRecipient (tUnqualified users), isCellsEvent = shouldPushToCells st e } + +toConversationCreated :: + UTCTime -> + Local UserId -> + StoredConversation -> + ConversationCreated ConvId +toConversationCreated now lusr StoredConversation {metadata = Public.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 = + Public.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 :: Public.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 :: Public.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 -> [Public.OtherMember] -> Public.OwnConversation + conv this others = + Public.OwnConversation + (tUntagged cnvId) + Public.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 + } + (Public.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 ConvStore.ConversationStore r, + Member (Error UnreachableBackends) r, + Member (Error FederationError) r, + Member BackendNotificationQueueAccess r, + Member (FederationAPIAccess FederatorClient) r, + Member TinyLog 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 = Public.cnvmCreator . (.metadata) . tUnqualified $ lc + + localNonCreators :: [Public.OtherMember] + localNonCreators = + fmap (localMemberToOther . tDomain $ lc) + . filter (\lm -> lm.id_ `notElem` creator) + . (.localMembers) + . tUnqualified + $ lc + + toMembers :: [RemoteMember] -> Set Public.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) + (Public.ConversationJoin (tUntagged <$> newMembers) roleNameWireMember joinType), + extraConversationData = def + } + + deleteOnUnreachable :: + ( Member ConvStore.ConversationStore r, + Member (Error UnreachableBackends) r, + Member TinyLog r + ) => + Sem r a -> + Sem r a + deleteOnUnreachable m = catch @UnreachableBackends m $ \e -> do + P.err . msg $ + val "Unreachable backend when notifying" + +++ val "error" + +++ (LT.pack . show $ e) + ConvStore.deleteConversation (tUnqualified lc).id_ + throw e + +notifyCreatedConversation :: + ( Member ConvStore.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 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 + + NS.pushNotifications =<< mapM (toPush now) c.localMembers + where + route + | Data.convType c == Public.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/Notification.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Notification.hs new file mode 100644 index 00000000000..831fb213e0e --- /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 00000000000..9141e495535 --- /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 00000000000..74d7884aa20 --- /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 StoredMeetingTuple StoredMeeting 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 00000000000..6852489701a --- /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 @StoredMeetingTuple @StoredMeeting) 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 00000000000..5f44bd7e6fa --- /dev/null +++ b/libs/wire-subsystems/src/Wire/MeetingsSubsystem.hs @@ -0,0 +1,39 @@ +{-# 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 -> + 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 00000000000..b004a2d4b6b --- /dev/null +++ b/libs/wire-subsystems/src/Wire/MeetingsSubsystem/Interpreter.hs @@ -0,0 +1,197 @@ +-- 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.Team.Feature (FeatureStatus (..), LockableFeature (..), MeetingsPremiumConfig) +import Wire.API.User (BaseProtocolTag (BaseProtocolMLSTag)) +import Wire.ConversationStore qualified as ConvStore +import Wire.ConversationSubsystem (ConversationSubsystem, createConversation) +import Wire.FeaturesConfigSubsystem (FeaturesConfigSubsystem, getFeatureForTeam) +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 ConversationSubsystem r, + Member TeamStore.TeamStore r, + Member FeaturesConfigSubsystem r, + Member (Embed IO) r, + Member (ErrorS 'NotATeamMember) r, + Member (ErrorS 'InvalidOperation) r + ) => + NominalDiffTime -> + InterpreterFor MeetingsSubsystem r +interpretMeetingsSubsystem validityPeriod = interpret $ \case + CreateMeeting zUser newMeeting -> + createMeetingImpl zUser newMeeting + GetMeeting zUser meetingId -> + getMeetingImpl zUser meetingId validityPeriod + +createMeetingImpl :: + ( Member Store.MeetingsStore r, + Member ConversationSubsystem r, + Member TeamStore.TeamStore r, + Member FeaturesConfigSubsystem r, + Member (Embed IO) r, + Member (ErrorS 'NotATeamMember) r, + Member (ErrorS 'InvalidOperation) r + ) => + Local UserId -> + API.NewMeeting -> + Sem r (API.Meeting, StoredConversation) +createMeetingImpl zUser newMeeting = 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 -> do + premiumFeature <- getFeatureForTeam @_ @MeetingsPremiumConfig teamId + let premium = + case premiumFeature of + LockableFeature {status = FeatureStatusEnabled} -> True + _ -> False + pure $ not premium + + -- Generate meeting ID + meetingId <- randomId + + -- 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 + } + + -- Create and store the conversation via ConversationSubsystem + lconv <- qualifyAs zUser <$> liftIO randomId + storedConv <- createConversation lconv zUser 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 5dc5e19c770..20ac5030975 100644 --- a/libs/wire-subsystems/wire-subsystems.cabal +++ b/libs/wire-subsystems/wire-subsystems.cabal @@ -244,6 +244,8 @@ library Wire.ConversationStore.Postgres Wire.ConversationSubsystem Wire.ConversationSubsystem.Interpreter + Wire.ConversationSubsystem.Notification + Wire.ConversationSubsystem.View Wire.DeleteQueue Wire.DeleteQueue.InMemory Wire.DomainRegistrationStore @@ -297,6 +299,10 @@ library Wire.LegalHoldStore.Cassandra.Queries Wire.LegalHoldStore.Env Wire.ListItems + Wire.MeetingsStore + Wire.MeetingsStore.Postgres + Wire.MeetingsSubsystem + Wire.MeetingsSubsystem.Interpreter Wire.Migration Wire.NotificationSubsystem Wire.NotificationSubsystem.Interpreter diff --git a/postgres-schema.sql b/postgres-schema.sql index a0f4b619b33..e3faf412b2e 100644 --- a/postgres-schema.sql +++ b/postgres-schema.sql @@ -177,6 +177,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 -- @@ -337,6 +360,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 -- @@ -450,6 +481,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/background-worker/background-worker.cabal b/services/background-worker/background-worker.cabal index 595e3d01eac..2b73310cbc5 100644 --- a/services/background-worker/background-worker.cabal +++ b/services/background-worker/background-worker.cabal @@ -42,6 +42,7 @@ library , exceptions , extended , extra + , galley-types , hasql-pool , HsOpenSSL , http-client diff --git a/services/background-worker/default.nix b/services/background-worker/default.nix index 011bc91bea0..58beb333294 100644 --- a/services/background-worker/default.nix +++ b/services/background-worker/default.nix @@ -16,6 +16,7 @@ , extended , extra , federator +, galley-types , gitignoreSource , hasql-pool , HsOpenSSL @@ -68,6 +69,7 @@ mkDerivation { exceptions extended extra + galley-types hasql-pool HsOpenSSL http-client diff --git a/services/background-worker/src/Wire/BackgroundWorker/Env.hs b/services/background-worker/src/Wire/BackgroundWorker/Env.hs index 11787f105c6..5e2774106d5 100644 --- a/services/background-worker/src/Wire/BackgroundWorker/Env.hs +++ b/services/background-worker/src/Wire/BackgroundWorker/Env.hs @@ -84,7 +84,8 @@ data Env = Env federationDomain :: Domain, postgresMigration :: PostgresMigrationOpts, gundeckEndpoint :: Endpoint, - brigEndpoint :: Endpoint + brigEndpoint :: Endpoint, + federator :: Maybe Endpoint } data BackendNotificationMetrics = BackendNotificationMetrics @@ -133,6 +134,7 @@ mkEnv opts = do postgresMigration = opts.postgresMigration brigEndpoint = opts.brig gundeckEndpoint = opts.gundeck + federator = opts.federator workerRunningGauge <- mkWorkerRunningGauge hasqlPool <- initPostgresPool opts.postgresqlPool opts.postgresql opts.postgresqlPassword amqpJobsPublisherChannel <- diff --git a/services/background-worker/src/Wire/BackgroundWorker/Jobs/Registry.hs b/services/background-worker/src/Wire/BackgroundWorker/Jobs/Registry.hs index 1c9b3416bd5..324e5d8f9ce 100644 --- a/services/background-worker/src/Wire/BackgroundWorker/Jobs/Registry.hs +++ b/services/background-worker/src/Wire/BackgroundWorker/Jobs/Registry.hs @@ -23,6 +23,8 @@ where import Data.Id import Data.Qualified import Data.Text qualified as T +import Data.Text.Lazy qualified as TL +import Galley.Types.Error (InternalError, internalErrorDescription) import Hasql.Pool (UsageError) import Imports import Polysemy @@ -45,11 +47,14 @@ import Wire.ConversationStore.Cassandra import Wire.ConversationStore.Postgres (interpretConversationStoreToPostgres) import Wire.ConversationSubsystem.Interpreter (interpretConversationSubsystem) import Wire.ExternalAccess.External +import Wire.FederationAPIAccess.Interpreter (FederationAPIAccessConfig (..), interpretFederationAPIAccess) import Wire.FireAndForget (interpretFireAndForget) import Wire.GundeckAPIAccess import Wire.NotificationSubsystem.Interpreter import Wire.ParseException import Wire.Rpc +import Wire.Sem.Concurrency (ConcurrencySafety (Unsafe)) +import Wire.Sem.Concurrency.IO (unsafelyPerformConcurrency) import Wire.Sem.Delay (runDelay) import Wire.Sem.Logger (mapLogger) import Wire.Sem.Logger.TinyLog (loggerToTinyLog) @@ -72,7 +77,15 @@ dispatchJob job = do MigrationToPostgresql -> interpretConversationStoreToCassandraAndPostgres env.cassandraGalley PostgresqlStorage -> interpretConversationStoreToPostgres runInterpreters env extEnv = do + let federationAPIAccessConfig = + FederationAPIAccessConfig + { ownDomain = env.federationDomain, + federatorEndpoint = env.federator, + http2Manager = env.http2Manager, + requestId = job.requestId + } runFinal @IO + . unsafelyPerformConcurrency @_ @'Unsafe . embedToFinal @IO . asyncToIOFinal . interpretRace @@ -82,6 +95,7 @@ dispatchJob job = do . mapError @UsageError (T.pack . show) . mapError @ParseException (T.pack . displayException) . mapError @MigrationError (T.pack . show) + . mapError @InternalError (TL.toStrict . internalErrorDescription) . interpretTinyLog env job.requestId job.jobId . runInputConst env.hasqlPool . runInputConst (toLocalUnsafe env.federationDomain ()) @@ -102,6 +116,7 @@ dispatchJob job = do . interpretBrigAccess env.brigEndpoint . interpretExternalAccess extEnv . runNotificationSubsystemGundeck (defaultNotificationSubsystemConfig job.requestId) + . interpretFederationAPIAccess federationAPIAccessConfig . interpretConversationSubsystem . interpretBackgroundJobsRunner diff --git a/services/background-worker/src/Wire/BackgroundWorker/Options.hs b/services/background-worker/src/Wire/BackgroundWorker/Options.hs index 6dc18f03a2b..35ee518c306 100644 --- a/services/background-worker/src/Wire/BackgroundWorker/Options.hs +++ b/services/background-worker/src/Wire/BackgroundWorker/Options.hs @@ -37,6 +37,7 @@ data Opts = Opts federatorInternal :: !Endpoint, brig :: Endpoint, gundeck :: Endpoint, + federator :: Maybe Endpoint, rabbitmq :: !RabbitMqOpts, -- | Seconds, Nothing for no timeout defederationTimeout :: Maybe Int, diff --git a/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs b/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs index e10ab43123d..0b6196284be 100644 --- a/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs +++ b/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs @@ -368,6 +368,7 @@ spec = do } gundeckEndpoint = undefined brigEndpoint = undefined + federator = Nothing backendNotificationMetrics <- mkBackendNotificationMetrics workerRunningGauge <- mkWorkerRunningGauge @@ -406,6 +407,7 @@ spec = do } gundeckEndpoint = undefined brigEndpoint = undefined + federator = Nothing backendNotificationMetrics <- mkBackendNotificationMetrics 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 cdb020a2223..014c3b50383 100644 --- a/services/background-worker/test/Test/Wire/Util.hs +++ b/services/background-worker/test/Test/Wire/Util.hs @@ -65,6 +65,7 @@ testEnv = do federationDomain = Domain "local" gundeckEndpoint = undefined brigEndpoint = undefined + federator = Nothing pure Env {..} runTestAppT :: AppT IO a -> Int -> IO a diff --git a/services/galley/default.nix b/services/galley/default.nix index 988d5378dc7..d6684de242c 100644 --- a/services/galley/default.nix +++ b/services/galley/default.nix @@ -296,6 +296,7 @@ mkDerivation { base containers extra + galley-types imports lens polysemy diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index f1d6b4f299c..15c8317682a 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -81,7 +81,6 @@ library Galley.API.Clients Galley.API.Create Galley.API.CustomBackend - Galley.API.Error Galley.API.Federation Galley.API.Internal Galley.API.LegalHold @@ -89,6 +88,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 +119,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 @@ -571,6 +572,7 @@ test-suite galley-tests , containers , extra >=1.3 , galley + , galley-types , imports , lens , polysemy diff --git a/services/galley/galley.integration.yaml b/services/galley/galley.integration.yaml index e2106c63e67..f588f4c5271 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/Action.hs b/services/galley/src/Galley/API/Action.hs index 10474662d9a..e65841a77ec 100644 --- a/services/galley/src/Galley/API/Action.hs +++ b/services/galley/src/Galley/API/Action.hs @@ -69,7 +69,6 @@ import Galley.API.Action.Kick import Galley.API.Action.Leave import Galley.API.Action.Notify import Galley.API.Action.Reset -import Galley.API.Error import Galley.API.MLS.Conversation import Galley.API.MLS.Migration import Galley.API.MLS.Removal @@ -78,6 +77,7 @@ import Galley.API.Util import Galley.Effects import Galley.Env (Env) import Galley.Options (Opts) +import Galley.Types.Error import Galley.Validation import Imports hiding ((\\)) import Polysemy diff --git a/services/galley/src/Galley/API/Clients.hs b/services/galley/src/Galley/API/Clients.hs index 60dae17eaaf..e260c25e5d0 100644 --- a/services/galley/src/Galley/API/Clients.hs +++ b/services/galley/src/Galley/API/Clients.hs @@ -25,7 +25,6 @@ import Data.Id import Data.Proxy import Data.Qualified import Data.Range -import Galley.API.Error import Galley.API.MLS.Removal import Galley.API.Query qualified as Query import Galley.API.Util @@ -33,6 +32,7 @@ import Galley.Effects import Galley.Effects.ClientStore qualified as E import Galley.Env import Galley.Types.Clients (clientIds) +import Galley.Types.Error import Imports import Network.AMQP qualified as Q import Polysemy diff --git a/services/galley/src/Galley/API/Create.hs b/services/galley/src/Galley/API/Create.hs index d22b336ea75..db1273fd18b 100644 --- a/services/galley/src/Galley/API/Create.hs +++ b/services/galley/src/Galley/API/Create.hs @@ -43,14 +43,14 @@ import Data.Range import Data.Set qualified as Set import Data.UUID.Tagged qualified as U import Galley.API.Action -import Galley.API.Error import Galley.API.MLS import Galley.API.Mapping import Galley.API.One2One import Galley.API.Util import Galley.App (Env) import Galley.Effects -import Galley.Options (Opts) +import Galley.Options +import Galley.Types.Error import Galley.Types.Teams (notTeamMember) import Galley.Validation import Imports hiding ((\\)) @@ -81,9 +81,9 @@ import Wire.API.Team.Permission hiding (self) import Wire.API.User import Wire.BrigAPIAccess import Wire.ConversationStore qualified as E +import Wire.ConversationSubsystem qualified as ConversationSubsystem import Wire.ConversationSubsystem.Interpreter (ConversationSubsystemConfig) import Wire.FeaturesConfigSubsystem -import Wire.FederationAPIAccess qualified as E import Wire.NotificationSubsystem import Wire.Sem.Now (Now) import Wire.Sem.Now qualified as Now @@ -102,11 +102,10 @@ import Wire.UserList -- | The public-facing endpoint for creating group conversations in the client -- API up to and including version 3. createGroupConversationUpToV3 :: - ( Member BackendNotificationQueueAccess r, - Member BrigAPIAccess r, + ( Member BrigAPIAccess r, Member ConversationStore r, + Member ConversationSubsystem.ConversationSubsystem r, Member (ErrorS 'ConvAccessDenied) r, - Member (Error FederationError) r, Member (Error InternalError) r, Member (Error InvalidInput) r, Member (ErrorS 'NotATeamMember) r, @@ -118,7 +117,6 @@ createGroupConversationUpToV3 :: Member (ErrorS ChannelsNotEnabled) r, Member (ErrorS NotAnMlsConversation) r, Member (Error UnreachableBackendsLegacy) r, - Member (FederationAPIAccess FederatorClient) r, Member NotificationSubsystem r, Member (Input Env) r, Member (Input Opts) r, @@ -136,22 +134,17 @@ createGroupConversationUpToV3 :: Maybe ConnId -> NewConv -> Sem r (ConversationResponse Public.OwnConversation) -createGroupConversationUpToV3 lusr conn newConv = mapError UnreachableBackendsLegacy $ - do - conv <- - createGroupConversationGeneric - lusr - conn - newConv - def - conversationCreated lusr conv +createGroupConversationUpToV3 lusr conn newConv = + mapError UnreachableBackendsLegacy $ + createGroupConversationGeneric lusr conn newConv + >>= conversationCreated lusr -- | The public-facing endpoint for creating group conversations in the client -- API in from version 4 to 8 createGroupOwnConversation :: - ( Member BackendNotificationQueueAccess r, - Member BrigAPIAccess r, + ( Member BrigAPIAccess r, Member ConversationStore r, + Member ConversationSubsystem.ConversationSubsystem r, Member (ErrorS 'ConvAccessDenied) r, Member (Error FederationError) r, Member (Error InternalError) r, @@ -197,9 +190,9 @@ createGroupOwnConversation lusr conn newConv = do -- | The public-facing endpoint for creating group conversations in the client -- API in version 9 and above. createGroupConversation :: - ( Member BackendNotificationQueueAccess r, - Member BrigAPIAccess r, + ( Member BrigAPIAccess r, Member ConversationStore r, + Member ConversationSubsystem.ConversationSubsystem r, Member (ErrorS 'ConvAccessDenied) r, Member (Error FederationError) r, Member (Error InternalError) r, @@ -222,7 +215,6 @@ createGroupConversation :: Member Now r, Member LegalHoldStore r, Member TeamStore r, - Member P.TinyLog r, Member FeaturesConfigSubsystem r, Member TeamCollaboratorsSubsystem r, Member Random r, @@ -263,11 +255,10 @@ createGroupConvAndMkResponse :: Member (Error NonFederatingBackends) r, Member (Error InternalError) r, Member (Error InvalidInput) r, - Member P.TinyLog r, Member (FederationAPIAccess FederatorClient) r, - Member BackendNotificationQueueAccess r, Member BrigAPIAccess r, Member ConversationStore r, + Member ConversationSubsystem.ConversationSubsystem r, Member NotificationSubsystem r, Member LegalHoldStore r, Member TeamStore r, @@ -286,16 +277,15 @@ createGroupConvAndMkResponse lusr conn newConv mkResponse = do let remoteDomains = void <$> snd (partitionQualified lusr $ newConv.newConvQualifiedUsers) enforceFederationProtocol (baseProtocolToProtocol newConv.newConvProtocol) remoteDomains checkFederationStatus (RemoteDomains $ Set.fromList remoteDomains) - dbConv <- createGroupConversationGeneric lusr conn newConv def + dbConv <- createGroupConversationGeneric lusr conn newConv mkResponse dbConv createGroupConversationGeneric :: forall r. - ( Member BackendNotificationQueueAccess r, - Member BrigAPIAccess r, + ( Member BrigAPIAccess r, Member ConversationStore r, + Member ConversationSubsystem.ConversationSubsystem r, Member (ErrorS 'ConvAccessDenied) r, - Member (Error FederationError) r, Member (Error InternalError) r, Member (Error InvalidInput) r, Member (ErrorS 'NotATeamMember) r, @@ -306,8 +296,6 @@ createGroupConversationGeneric :: Member (ErrorS 'MissingLegalholdConsent) r, Member (ErrorS ChannelsNotEnabled) r, Member (ErrorS NotAnMlsConversation) r, - Member (Error UnreachableBackends) r, - Member (FederationAPIAccess FederatorClient) r, Member NotificationSubsystem r, Member (Input Env) r, Member (Input Opts) r, @@ -315,7 +303,6 @@ createGroupConversationGeneric :: Member Now r, Member LegalHoldStore r, Member TeamStore r, - Member P.TinyLog r, Member FeaturesConfigSubsystem r, Member TeamCollaboratorsSubsystem r, Member Random r, @@ -324,9 +311,8 @@ createGroupConversationGeneric :: Local UserId -> Maybe ConnId -> NewConv -> - JoinType -> Sem r StoredConversation -createGroupConversationGeneric lusr conn newConv joinType = do +createGroupConversationGeneric lusr conn newConv = do (nc, fromConvSize -> allUsers) <- newRegularConversation lusr newConv checkCreateConvPermissions lusr newConv newConv.newConvTeam allUsers ensureNoLegalholdConflicts allUsers @@ -336,12 +322,11 @@ createGroupConversationGeneric lusr conn newConv joinType = do assertMLSEnabled lcnv <- traverse (const $ Id <$> Random.uuid) lusr - conv <- E.upsertConversation lcnv nc + conv <- ConversationSubsystem.createConversation lcnv lusr nc -- NOTE: We only send (conversation) events to members of the conversation - notifyCreatedConversation lusr conn conv joinType sendCellsNotification conv - E.getConversation (tUnqualified lcnv) - >>= note (BadConvState (tUnqualified lcnv)) + E.getConversation conv.id_ + >>= note (BadConvState conv.id_) where sendCellsNotification :: StoredConversation -> Sem r () sendCellsNotification conv = do @@ -428,6 +413,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) @@ -468,6 +455,7 @@ getTeamMember uid Nothing = TeamStore.getUserTeams uid >>= maybe (pure Nothing) createProteusSelfConversation :: forall r. ( Member ConversationStore r, + Member ConversationSubsystem.ConversationSubsystem r, Member (Error InternalError) r, Member P.TinyLog r ) => @@ -487,13 +475,13 @@ createProteusSelfConversation lusr = do protocol = BaseProtocolProteusTag, groupId = Nothing } - c <- E.upsertConversation lcnv nc - conversationCreated lusr c + ConversationSubsystem.createConversation lcnv lusr nc + >>= conversationCreated lusr createOne2OneConversation :: - ( Member BackendNotificationQueueAccess r, - Member BrigAPIAccess r, + ( Member BrigAPIAccess r, Member ConversationStore r, + Member ConversationSubsystem.ConversationSubsystem r, Member (Error FederationError) r, Member (Error InternalError) r, Member (Error InvalidInput) r, @@ -505,9 +493,6 @@ createOne2OneConversation :: Member (ErrorS 'InvalidOperation) r, Member (ErrorS 'NotConnected) r, Member (Error UnreachableBackendsLegacy) r, - Member (FederationAPIAccess FederatorClient) r, - Member NotificationSubsystem r, - Member Now r, Member TeamStore r, Member P.TinyLog r, Member TeamCollaboratorsSubsystem r, @@ -587,14 +572,10 @@ createOne2OneConversation lusr zcon j = else throwS @OperationDenied createLegacyOne2OneConversationUnchecked :: - ( Member BackendNotificationQueueAccess r, - Member ConversationStore r, - Member (Error FederationError) r, + ( Member ConversationStore r, + Member ConversationSubsystem.ConversationSubsystem r, Member (Error InternalError) r, Member (Error InvalidInput) r, - Member (FederationAPIAccess FederatorClient) r, - Member NotificationSubsystem r, - Member Now r, Member P.TinyLog r ) => Local UserId -> @@ -603,7 +584,7 @@ createLegacyOne2OneConversationUnchecked :: Maybe TeamId -> Local UserId -> Sem r (ConversationResponse Public.OwnConversation) -createLegacyOne2OneConversationUnchecked self zcon name mtid other = do +createLegacyOne2OneConversationUnchecked self _zcon name mtid other = do lcnv <- localOne2OneConvId self other let meta = (defConversationMetadata (Just (tUnqualified self))) @@ -622,23 +603,14 @@ createLegacyOne2OneConversationUnchecked self zcon name mtid other = do case mc of Just c -> conversationExisted self c Nothing -> do - c <- E.upsertConversation lcnv nc - runError @UnreachableBackends (notifyCreatedConversation self (Just zcon) c def) - >>= \case - Left _ -> do - throw . InternalErrorWithDescription $ - "A one-to-one conversation on one backend cannot involve unreachable backends" - Right () -> conversationCreated self c + ConversationSubsystem.createConversation lcnv self nc + >>= conversationCreated self createOne2OneConversationUnchecked :: - ( Member BackendNotificationQueueAccess r, - Member ConversationStore r, + ( Member ConversationStore r, + Member ConversationSubsystem.ConversationSubsystem 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 -> @@ -656,14 +628,9 @@ createOne2OneConversationUnchecked self zcon name mtid other = do create (one2OneConvId BaseProtocolProteusTag (tUntagged self) other) self zcon name mtid other createOne2OneConversationLocally :: - ( Member BackendNotificationQueueAccess r, - Member ConversationStore r, - Member (Error FederationError) r, + ( Member ConversationStore r, + Member ConversationSubsystem.ConversationSubsystem r, Member (Error InternalError) r, - Member (Error UnreachableBackends) r, - Member (FederationAPIAccess FederatorClient) r, - Member NotificationSubsystem r, - Member Now r, Member P.TinyLog r ) => Local ConvId -> @@ -673,7 +640,7 @@ createOne2OneConversationLocally :: Maybe TeamId -> Qualified UserId -> Sem r (ConversationResponse Public.OwnConversation) -createOne2OneConversationLocally lcnv self zcon name mtid other = do +createOne2OneConversationLocally lcnv self _zcon name mtid other = do mc <- E.getConversation (tUnqualified lcnv) case mc of Just c -> conversationExisted self c @@ -691,9 +658,8 @@ createOne2OneConversationLocally lcnv self zcon name mtid other = do protocol = BaseProtocolProteusTag, groupId = Nothing } - c <- E.upsertConversation lcnv nc - notifyCreatedConversation self (Just zcon) c def - conversationCreated self c + ConversationSubsystem.createConversation lcnv self nc + >>= conversationCreated self createOne2OneConversationRemotely :: (Member (Error FederationError) r) => @@ -708,15 +674,13 @@ createOne2OneConversationRemotely _ _ _ _ _ _ = throw FederationNotImplemented createConnectConversation :: - ( Member BackendNotificationQueueAccess r, - Member ConversationStore r, + ( Member ConversationStore r, + Member ConversationSubsystem.ConversationSubsystem r, Member (ErrorS 'ConvNotFound) r, Member (Error FederationError) r, Member (Error InternalError) r, Member (Error InvalidInput) r, Member (ErrorS 'InvalidOperation) r, - Member (Error UnreachableBackends) r, - Member (FederationAPIAccess FederatorClient) r, Member NotificationSubsystem r, Member Now r, Member P.TinyLog r @@ -747,20 +711,7 @@ createConnectConversation lusr conn j = do >>= maybe (create lcnv nc) (update n) 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 - } - ] + c <- ConversationSubsystem.createConversation lcnv lusr nc conversationCreated lusr c update n conv = do let mems = conv.localMembers @@ -787,24 +738,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 @@ -879,58 +818,6 @@ conversationCreated :: Sem r (ConversationResponse Public.OwnConversation) conversationCreated lusr cnv = Created <$> conversationViewV9 lusr cnv --- | The return set contains all the remote users that could not be contacted. --- Consequently, the unreachable users are not added to the member list. This --- behavior might be changed later on when a message/event queue per remote --- backend is implemented. -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 - } - localOne2OneConvId :: (Member (Error InvalidInput) r) => Local UserId -> diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index 725117fe7f6..f476a7ff6ee 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -37,7 +37,6 @@ import Data.Singletons (SingI (..), demote, sing) import Data.Tagged import Data.Text.Lazy qualified as LT import Galley.API.Action -import Galley.API.Error import Galley.API.MLS import Galley.API.MLS.Enabled import Galley.API.MLS.GroupInfo @@ -56,6 +55,7 @@ import Galley.App import Galley.Effects import Galley.Options import Galley.Types.Conversations.One2One +import Galley.Types.Error import Imports import Network.Wai.Utilities.Exception import Polysemy diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index 7c50cd9d5ee..9a21fd3c3f2 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -39,7 +39,6 @@ import Data.Time import Galley.API.Action import Galley.API.Clients qualified as Clients import Galley.API.Create qualified as Create -import Galley.API.Error import Galley.API.LegalHold (unsetTeamLegalholdWhitelistedH) import Galley.API.LegalHold.Conflicts import Galley.API.MLS.Removal @@ -60,6 +59,7 @@ import Galley.Env (FanoutLimit) import Galley.Monad import Galley.Options hiding (brig) import Galley.Queue qualified as Q +import Galley.Types.Error import Imports hiding (head) import Network.AMQP qualified as Q import Polysemy diff --git a/services/galley/src/Galley/API/LegalHold.hs b/services/galley/src/Galley/API/LegalHold.hs index 2aa4a480886..9007a8c8111 100644 --- a/services/galley/src/Galley/API/LegalHold.hs +++ b/services/galley/src/Galley/API/LegalHold.hs @@ -41,7 +41,6 @@ import Data.Misc import Data.Proxy (Proxy (Proxy)) import Data.Qualified import Data.Range (toRange) -import Galley.API.Error import Galley.API.LegalHold.Get import Galley.API.LegalHold.Team import Galley.API.Query (iterateConversations) @@ -51,6 +50,7 @@ import Galley.App import Galley.Effects import Galley.Effects.TeamMemberStore import Galley.External.LegalHoldService qualified as LHService +import Galley.Types.Error import Galley.Types.Teams as Team import Imports import Network.HTTP.Types.Status (status200) diff --git a/services/galley/src/Galley/API/LegalHold/Get.hs b/services/galley/src/Galley/API/LegalHold/Get.hs index e6ac3379fac..37c90544250 100644 --- a/services/galley/src/Galley/API/LegalHold/Get.hs +++ b/services/galley/src/Galley/API/LegalHold/Get.hs @@ -22,8 +22,8 @@ import Data.ByteString.Conversion (toByteString') import Data.Id import Data.LegalHold (UserLegalHoldStatus (..)) import Data.Qualified -import Galley.API.Error import Galley.Effects +import Galley.Types.Error import Imports import Polysemy import Polysemy.Error diff --git a/services/galley/src/Galley/API/MLS.hs b/services/galley/src/Galley/API/MLS.hs index 7a83ac92146..0d0d5abe601 100644 --- a/services/galley/src/Galley/API/MLS.hs +++ b/services/galley/src/Galley/API/MLS.hs @@ -27,10 +27,10 @@ module Galley.API.MLS where import Data.Default -import Galley.API.Error import Galley.API.MLS.Enabled import Galley.API.MLS.Message import Galley.Env +import Galley.Types.Error import Imports import Polysemy import Polysemy.Error diff --git a/services/galley/src/Galley/API/MLS/Commit/Core.hs b/services/galley/src/Galley/API/MLS/Commit/Core.hs index 966693c5940..6b3a49b4779 100644 --- a/services/galley/src/Galley/API/MLS/Commit/Core.hs +++ b/services/galley/src/Galley/API/MLS/Commit/Core.hs @@ -31,13 +31,13 @@ where import Control.Comonad import Data.Id import Data.Qualified -import Galley.API.Error import Galley.API.MLS.Conversation import Galley.API.MLS.IncomingMessage import Galley.API.MLS.Proposal import Galley.Effects import Galley.Env import Galley.Options +import Galley.Types.Error import Imports import Polysemy import Polysemy.Error diff --git a/services/galley/src/Galley/API/MLS/Commit/InternalCommit.hs b/services/galley/src/Galley/API/MLS/Commit/InternalCommit.hs index ac15b43399f..e5d234ac33d 100644 --- a/services/galley/src/Galley/API/MLS/Commit/InternalCommit.hs +++ b/services/galley/src/Galley/API/MLS/Commit/InternalCommit.hs @@ -30,7 +30,6 @@ import Data.Qualified import Data.Set qualified as Set import Data.Tuple.Extra import Galley.API.Action -import Galley.API.Error import Galley.API.MLS.CheckClients import Galley.API.MLS.Commit.Core import Galley.API.MLS.Conversation @@ -40,6 +39,7 @@ import Galley.API.MLS.Proposal import Galley.API.MLS.Util import Galley.API.Util import Galley.Effects +import Galley.Types.Error import Imports import Polysemy import Polysemy.Error diff --git a/services/galley/src/Galley/API/MLS/Message.hs b/services/galley/src/Galley/API/MLS/Message.hs index 8ca29cac361..aeef15f5a48 100644 --- a/services/galley/src/Galley/API/MLS/Message.hs +++ b/services/galley/src/Galley/API/MLS/Message.hs @@ -41,7 +41,6 @@ import Data.Tagged import Data.Text.Lazy qualified as LT import Data.Tuple.Extra import Galley.API.Action -import Galley.API.Error import Galley.API.LegalHold.Get (getUserStatus) import Galley.API.MLS.Commit.Core (getCommitData) import Galley.API.MLS.Commit.ExternalCommit @@ -58,6 +57,7 @@ import Galley.API.MLS.Util import Galley.API.MLS.Welcome (sendWelcomes) import Galley.API.Util import Galley.Effects +import Galley.Types.Error import Imports import Polysemy import Polysemy.Error diff --git a/services/galley/src/Galley/API/MLS/Proposal.hs b/services/galley/src/Galley/API/MLS/Proposal.hs index 68dc6a0a7a4..e7c3704a482 100644 --- a/services/galley/src/Galley/API/MLS/Proposal.hs +++ b/services/galley/src/Galley/API/MLS/Proposal.hs @@ -38,12 +38,12 @@ import Data.Id import Data.Map qualified as Map import Data.Qualified import Data.Set qualified as Set -import Galley.API.Error import Galley.API.MLS.IncomingMessage import Galley.API.Util import Galley.Effects import Galley.Env import Galley.Options +import Galley.Types.Error import Imports import Polysemy import Polysemy.Error diff --git a/services/galley/src/Galley/API/MLS/Reset.hs b/services/galley/src/Galley/API/MLS/Reset.hs index 5d9515c9722..d9b6abc0674 100644 --- a/services/galley/src/Galley/API/MLS/Reset.hs +++ b/services/galley/src/Galley/API/MLS/Reset.hs @@ -20,12 +20,12 @@ module Galley.API.MLS.Reset (resetMLSConversation) where import Data.Id import Data.Qualified import Galley.API.Action -import Galley.API.Error import Galley.API.MLS.Enabled import Galley.API.MLS.Util import Galley.API.Update import Galley.Effects import Galley.Env +import Galley.Types.Error import Imports import Polysemy import Polysemy.Error diff --git a/services/galley/src/Galley/API/Mapping.hs b/services/galley/src/Galley/API/Mapping.hs index 91d2c338c7b..d4b66ede388 100644 --- a/services/galley/src/Galley/API/Mapping.hs +++ b/services/galley/src/Galley/API/Mapping.hs @@ -28,7 +28,7 @@ where import Data.Domain (Domain) import Data.Id (UserId, idToText) import Data.Qualified -import Galley.API.Error +import Galley.Types.Error import Imports import Polysemy import Polysemy.Error diff --git a/services/galley/src/Galley/API/Meetings.hs b/services/galley/src/Galley/API/Meetings.hs new file mode 100644 index 00000000000..d73ad1e8c71 --- /dev/null +++ b/services/galley/src/Galley/API/Meetings.hs @@ -0,0 +1,114 @@ +-- 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.Types.Error +import Imports +import Polysemy +import Polysemy.Error (Error, runError, throw) +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) +import Wire.BackendNotificationQueueAccess +import Wire.ConversationStore (ConversationStore) +import Wire.ConversationSubsystem.Notification (notifyCreatedConversation) +import Wire.ConversationSubsystem.View qualified as ViewError +import Wire.FeaturesConfigSubsystem (FeaturesConfigSubsystem, getFeatureForTeam) +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 FeaturesConfigSubsystem r, + Member (ErrorS 'InvalidOperation) 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 FeaturesConfigSubsystem r + ) => + Local UserId -> + NewMeeting -> + Sem r Meeting +createMeeting lUser newMeeting = do + -- Check if meetings feature is enabled + checkMeetingsEnabled (tUnqualified lUser) + + (meeting, conversation) <- Meetings.createMeeting lUser newMeeting + 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 FeaturesConfigSubsystem r, + Member (ErrorS 'InvalidOperation) 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 00000000000..71bd0e8d6a3 --- /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 ea777ec4992..7db4f47181a 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/Query.hs b/services/galley/src/Galley/API/Query.hs index ee61bf748a4..4595cb9ee00 100644 --- a/services/galley/src/Galley/API/Query.hs +++ b/services/galley/src/Galley/API/Query.hs @@ -66,7 +66,6 @@ import Data.Qualified import Data.Range import Data.Set qualified as Set import Data.Tagged -import Galley.API.Error import Galley.API.MLS import Galley.API.MLS.Enabled import Galley.API.MLS.One2One @@ -77,6 +76,7 @@ import Galley.API.Teams.Features.Get import Galley.API.Util import Galley.Effects import Galley.Env +import Galley.Types.Error import Imports import Polysemy import Polysemy.Error diff --git a/services/galley/src/Galley/API/Teams.hs b/services/galley/src/Galley/API/Teams.hs index 2ac49386349..22deafd2e01 100644 --- a/services/galley/src/Galley/API/Teams.hs +++ b/services/galley/src/Galley/API/Teams.hs @@ -77,7 +77,6 @@ import Data.Set qualified as Set import Data.Singletons import Data.Time.Clock (UTCTime) import Galley.API.Action -import Galley.API.Error as Galley import Galley.API.LegalHold.Team import Galley.API.Teams.Features.Get import Galley.API.Teams.Notifications qualified as APITeamQueue @@ -90,6 +89,7 @@ import Galley.Effects.SearchVisibilityStore qualified as SearchVisibilityData import Galley.Effects.TeamMemberStore qualified as E import Galley.Env import Galley.Options +import Galley.Types.Error as Galley import Galley.Types.Teams import Imports hiding (forkIO) import Polysemy diff --git a/services/galley/src/Galley/API/Teams/Features.hs b/services/galley/src/Galley/API/Teams/Features.hs index 4c9bf4b9797..349d6d56326 100644 --- a/services/galley/src/Galley/API/Teams/Features.hs +++ b/services/galley/src/Galley/API/Teams/Features.hs @@ -41,7 +41,6 @@ import Data.Id import Data.Json.Util import Data.Kind import Data.Qualified (Local) -import Galley.API.Error (InternalError) import Galley.API.LegalHold qualified as LegalHold import Galley.API.LegalHold.Team qualified as LegalHold import Galley.API.Teams.Features.Get @@ -51,6 +50,7 @@ import Galley.Effects import Galley.Effects.SearchVisibilityStore qualified as SearchVisibilityData import Galley.Env (FanoutLimit) import Galley.Options +import Galley.Types.Error (InternalError) import Galley.Types.Teams import Imports import Polysemy diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index fd4e4606b8a..cbd948dd391 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -91,7 +91,6 @@ import Data.Singletons import Data.Vector qualified as V import Galley.API.Action import Galley.API.Action.Kick (kickMember) -import Galley.API.Error import Galley.API.Mapping import Galley.API.Message import Galley.API.Query qualified as Query @@ -102,6 +101,7 @@ import Galley.Effects import Galley.Effects.ClientStore qualified as E import Galley.Env import Galley.Options +import Galley.Types.Error import Imports hiding (forkIO) import Polysemy import Polysemy.Error diff --git a/services/galley/src/Galley/API/Util.hs b/services/galley/src/Galley/API/Util.hs index d8a1143b9ef..beabe54bb34 100644 --- a/services/galley/src/Galley/API/Util.hs +++ b/services/galley/src/Galley/API/Util.hs @@ -40,13 +40,14 @@ import Data.Set qualified as Set import Data.Singletons import Data.Text qualified as T import Data.Time -import Galley.API.Error import Galley.API.Mapping import Galley.Effects import Galley.Effects.ClientStore import Galley.Env +import Galley.Options () import Galley.Types.Clients (Clients, fromUserClients) import Galley.Types.Conversations.Roles +import Galley.Types.Error import Galley.Types.Teams import Imports hiding (forkIO) import Network.AMQP qualified as Q @@ -1187,3 +1188,29 @@ instance if err' == demote @e then throwS @e else rethrowErrors @effs @r err' + +---------------------------------------------------------------------------- +-- Notifications +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 2035a64c1cf..88bc33fe4f9 100644 --- a/services/galley/src/Galley/App.hs +++ b/services/galley/src/Galley/App.hs @@ -52,7 +52,6 @@ import Data.Misc import Data.Qualified import Data.Range import Data.Text qualified as Text -import Galley.API.Error import Galley.Cassandra.Client import Galley.Cassandra.CustomBackend import Galley.Cassandra.SearchVisibility @@ -72,6 +71,7 @@ import Galley.Options hiding (brig, endpoint, federator) import Galley.Options qualified as O import Galley.Queue import Galley.Queue qualified as Q +import Galley.Types.Error import Galley.Types.Teams import HTTP2.Client.Manager (Http2Manager, http2ManagerWithSSLCtx) import Hasql.Pool qualified as Hasql @@ -123,8 +123,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 @@ -288,7 +291,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) @@ -352,6 +365,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 @@ -387,6 +402,7 @@ evalGalley e = . interpretProposalStoreToCassandra . convCodesStoreInterpreter . interpretClientStoreToCassandra + . interpretMeetingsStoreToPostgres . interpretTeamCollaboratorsStoreToPostgres . interpretFireAndForget . BackendNotificationQueueAccess.interpretBackendNotificationQueueAccess backendNotificationQueueAccessEnv @@ -401,8 +417,11 @@ evalGalley e = . runFeaturesConfigSubsystem . runInputSem getAllTeamFeaturesForServer . 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 af09983856f..cb395dd7afd 100644 --- a/services/galley/src/Galley/Effects.hs +++ b/services/galley/src/Galley/Effects.hs @@ -96,6 +96,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 @@ -116,6 +118,7 @@ import Wire.UserGroupStore -- All the possible high-level effects. type GalleyEffects1 = '[ TeamCollaboratorsSubsystem, + MeetingsSubsystem, ConversationSubsystem, Input AllTeamFeatures, FeaturesConfigSubsystem, @@ -130,6 +133,7 @@ type GalleyEffects1 = BackendNotificationQueueAccess, FireAndForget, TeamCollaboratorsStore, + MeetingsStore, ClientStore, CodeStore, ProposalStore, @@ -164,5 +168,7 @@ type GalleyEffects1 = Error DynError, Error RateLimitExceeded, ErrorS OperationDenied, - ErrorS 'NotATeamMember + ErrorS 'NotATeamMember, + ErrorS 'MeetingNotFound, + ErrorS 'InvalidOperation ] diff --git a/services/galley/src/Galley/External/LegalHoldService/Internal.hs b/services/galley/src/Galley/External/LegalHoldService/Internal.hs index eac3a0d0100..6834a6426ab 100644 --- a/services/galley/src/Galley/External/LegalHoldService/Internal.hs +++ b/services/galley/src/Galley/External/LegalHoldService/Internal.hs @@ -29,9 +29,9 @@ import Control.Retry import Data.ByteString qualified as BS import Data.ByteString.Lazy.Char8 qualified as LC8 import Data.Misc -import Galley.API.Error import Galley.Env import Galley.Monad +import Galley.Types.Error import Imports import Network.HTTP.Client qualified as Http import OpenSSL.Session qualified as SSL diff --git a/services/galley/src/Galley/Options.hs b/services/galley/src/Galley/Options.hs index a435707a7e6..eba206c223b 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 diff --git a/services/galley/src/Galley/Validation.hs b/services/galley/src/Galley/Validation.hs index 7d045d21026..6c43091116f 100644 --- a/services/galley/src/Galley/Validation.hs +++ b/services/galley/src/Galley/Validation.hs @@ -29,8 +29,8 @@ where import Control.Lens import Data.Range import GHC.TypeNats -import Galley.API.Error import Galley.Options +import Galley.Types.Error import Imports import Polysemy import Polysemy.Error diff --git a/services/galley/test/unit/Test/Galley/Mapping.hs b/services/galley/test/unit/Test/Galley/Mapping.hs index d8e36e1ad91..b73a27c17b4 100644 --- a/services/galley/test/unit/Test/Galley/Mapping.hs +++ b/services/galley/test/unit/Test/Galley/Mapping.hs @@ -25,8 +25,8 @@ import Data.Domain import Data.Id import Data.Qualified import Data.Set qualified as Set -import Galley.API.Error (InternalError) import Galley.API.Mapping +import Galley.Types.Error (InternalError) import Imports import Polysemy (Sem) import Polysemy qualified as P