{-# OPTIONS_GHC -Wno-ambiguous-fields #-}

-- This file is part of the Wire Server implementation.
--
-- Copyright (C) 2026 Wire Swiss GmbH <opensource@wire.com>
--
-- This program is free software: you can redistribute it and/or modify it under
-- the terms of the GNU Affero General Public License as published by the Free
-- Software Foundation, either version 3 of the License, or (at your option) any
-- later version.
--
-- This program is distributed in the hope that it will be useful, but WITHOUT
-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more
-- details.
--
-- You should have received a copy of the GNU Affero General Public License along
-- with this program. If not, see <https://www.gnu.org/licenses/>.

module Test.Meetings where

import API.Galley
import qualified API.GalleyInternal as I
import Control.Monad.Reader (ask)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import Data.Time.Clock
import qualified Data.Time.Format as Time
import Data.Time.Format.ISO8601 (iso8601ParseM)
import MLS.Util
import Notifications (isConvCreateMeetingNotif, isConvDeleteMeetingNotif, isMeetingCreateNotif, isMeetingDeleteNotif, isMeetingMemberAddNotif, isMeetingUpdateNotif, isMemberJoinNotif, isWelcomeNotif)
import SetupHelpers
import System.Timeout (timeout)
import Testlib.Prelude
import Text.Regex.TDFA ((=~))
import UnliftIO.Concurrent (threadDelay)

testMeetingCreate :: (HasCallStack) => App ()
testMeetingCreate :: HasCallStack => App ()
testMeetingCreate = do
  (owner, _tid, _members) <- Domain -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam Domain
OwnDomain Int
1
  ownerId <- owner %. "id" >>= asString
  now <- liftIO getCurrentTime
  let startTime = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
3600 UTCTime
now
      endTime = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
7200 UTCTime
now
      newMeeting = String -> UTCTime -> UTCTime -> [String] -> Value
defaultMeetingJson String
"Team Standup" UTCTime
startTime UTCTime
endTime [String
"alice@example.com", String
"bob@example.com"]

  meeting <-
    withWebSocket owner $ \WebSocket
ws -> do
      resp <- Value -> Value -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> Value -> App Response
postMeetings Value
owner Value
newMeeting
      assertSuccess resp
      void $ awaitMatch isConvCreateMeetingNotif ws
      m <- getJSON 201 resp
      -- the creator's other client connection (this websocket) now receives meeting.create
      void $ awaitMatch isMeetingCreateNotif ws
      pure m

  meeting %. "title" `shouldMatch` ("Team Standup" :: String)
  meeting %. "qualified_creator" %. "id" `shouldMatch` ownerId
  meeting %. "invited_emails" `shouldMatch` (["alice@example.com", "bob@example.com"] :: [String])

  -- The full conversation is returned alongside the legacy field
  assertConversationMatchesLegacy meeting

  meeting %. "conversation" %. "access" `shouldMatchSet` ["invite", "code"]

  -- Verify fetching the meeting
  (meetingId, domain) <- getMeetingIdAndDomain meeting
  r2 <- getMeeting owner domain meetingId
  assertSuccess r2

  fetchedMeeting <- getJSON 200 r2
  fetchedMeeting %. "title" `shouldMatch` ("Team Standup" :: String)

-- Regression: meeting conversations must grant InviteAccess so that MLS
-- commits adding participants succeed. Without InviteAccess, Galley rejects
-- the join in performConversationJoin (ensureAccess conv InviteAccess) with
-- 403 access-denied.
testMeetingMLSAddParticipant :: (HasCallStack) => App ()
testMeetingMLSAddParticipant :: HasCallStack => App ()
testMeetingMLSAddParticipant = do
  (alice, _tid, [bob]) <- Domain -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam Domain
OwnDomain Int
2
  alice1 <- createMLSClient def alice
  bob1 <- createMLSClient def bob
  _ <- uploadNewKeyPackage def bob1
  now <- liftIO getCurrentTime
  let startTime = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
3600 UTCTime
now
      endTime = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
7200 UTCTime
now
      newMeeting = String -> UTCTime -> UTCTime -> [String] -> Value
defaultMeetingJson String
"MLS Meeting" UTCTime
startTime UTCTime
endTime []

  meeting <- postMeetings alice newMeeting >>= getJSON 201
  convQid <- meeting %. "qualified_conversation"

  conv <- getConversation alice convQid >>= getJSON 200
  convId <- objConvId conv
  createGroup def alice1 convId

  memberAddNotif <-
    withWebSocket bob $ \WebSocket
ws -> do
      App Value -> App ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (App Value -> App ()) -> App Value -> App ()
forall a b. (a -> b) -> a -> b
$ HasCallStack =>
ClientIdentity -> ConvId -> [Value] -> App MessagePackage
ClientIdentity -> ConvId -> [Value] -> App MessagePackage
createAddCommit ClientIdentity
alice1 ConvId
convId [Value
bob] App MessagePackage -> (MessagePackage -> App Value) -> App Value
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => MessagePackage -> App Value
MessagePackage -> App Value
sendAndConsumeCommitBundle
      let isMeetingAddSequenceNotif :: a -> App Bool
isMeetingAddSequenceNotif a
notif = do
            isMemberJoin <- a -> App Bool
forall a. (HasCallStack, MakesValue a) => a -> App Bool
isMemberJoinNotif a
notif
            isMeetingMemberAdd <- isMeetingMemberAddNotif notif
            isWelcome <- isWelcomeNotif notif
            pure $ isMemberJoin || isMeetingMemberAdd || isWelcome
      sequenceNotifs <- Int -> App Value -> App [Value]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
3 (HasCallStack => (Value -> App Bool) -> WebSocket -> App Value
(Value -> App Bool) -> WebSocket -> App Value
awaitMatch Value -> App Bool
forall {a}. MakesValue a => a -> App Bool
isMeetingAddSequenceNotif WebSocket
ws)
      sequenceTypes <- for sequenceNotifs $ \Value
notif -> Value
notif Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"payload.0.type" App Value -> (Value -> App String) -> App String
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString
      sequenceTypes
        `shouldMatchSet` [ "conversation.member-join",
                           "meeting.member-add",
                           "conversation.mls-welcome"
                         ]
      case [n | (t, n) <- zip sequenceTypes sequenceNotifs, t == "meeting.member-add"] of
        (Value
notif : [Value]
_) -> Value -> App Value
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
notif
        [] -> String -> App Value
forall a. HasCallStack => String -> App a
assertFailure String
"expected a meeting.member-add notification in the add sequence"

  assertMeetingNotif memberAddNotif (meeting %. "qualified_id")
  memberAddNotif %. "payload.0.qualified_conversation" `shouldMatch` convQid

  bindResponse (getConversation alice convQid) $ \Response
res -> do
    Response
res.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
    ([Value] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Value] -> Int) -> App [Value] -> App Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Response
res.json Maybe Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"members.others" App Value -> (App Value -> App [Value]) -> App [Value]
forall a b. a -> (a -> b) -> b
& App Value -> App [Value]
forall a. (HasCallStack, MakesValue a) => a -> App [Value]
asList)) App Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
1
    Response
res.json Maybe Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"members.others.0.qualified_id" App Value -> App Value -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` Value -> App Value
forall a. (HasCallStack, MakesValue a) => a -> App Value
objQidObject Value
bob

-- | Helper to extract meetingId and domain from a meeting JSON object
getMeetingIdAndDomain :: (HasCallStack) => Value -> App (String, String)
getMeetingIdAndDomain :: HasCallStack => Value -> App (String, String)
getMeetingIdAndDomain Value
meeting = do
  meetingId <- Value
meeting Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"qualified_id" App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"id" App Value -> (Value -> App String) -> App String
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString
  domain <- meeting %. "qualified_id" %. "domain" >>= asString
  pure (meetingId, domain)

-- | On create/update responses, the full @conversation@ object is returned
-- alongside the legacy @qualified_conversation@ field. This asserts that both
-- refer to the same conversation.
assertConversationMatchesLegacy :: (HasCallStack) => Value -> App ()
assertConversationMatchesLegacy :: HasCallStack => Value -> App ()
assertConversationMatchesLegacy Value
meeting = do
  convId <- Value
meeting Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"conversation" App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"qualified_id"
  legacyConvId <- meeting %. "qualified_conversation"
  convId `shouldMatch` legacyConvId

-- | Assert a meeting lifecycle notification carries the meeting's qualified id flat
-- at payload.0.qualified_id and has NO "data" wrapper (proves the no-nesting
-- contract).
assertMeetingNotif ::
  (HasCallStack, MakesValue notif, MakesValue qid) =>
  notif ->
  qid ->
  App ()
assertMeetingNotif :: forall notif qid.
(HasCallStack, MakesValue notif, MakesValue qid) =>
notif -> qid -> App ()
assertMeetingNotif notif
notif qid
qid = do
  notif
notif notif -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"payload.0.qualified_id" App Value -> qid -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` qid
qid
  notif -> String -> App ()
forall a. (HasCallStack, MakesValue a) => a -> String -> App ()
assertFieldMissing notif
notif String
"payload.0.data"

-- | Helper to create a default new meeting JSON object
defaultMeetingJson :: String -> UTCTime -> UTCTime -> [String] -> Value
defaultMeetingJson :: String -> UTCTime -> UTCTime -> [String] -> Value
defaultMeetingJson String
title UTCTime
startTime UTCTime
endTime [String]
invitedEmails =
  [Pair] -> Value
object
    [ String
"title" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= String
title,
      String
"start_time" String -> UTCTime -> Pair
forall a. ToJSON a => String -> a -> Pair
.= UTCTime
startTime,
      String
"end_time" String -> UTCTime -> Pair
forall a. ToJSON a => String -> a -> Pair
.= UTCTime
endTime,
      String
"tzid" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= (String
"Europe/Berlin" :: String),
      String
"type" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= (String
"scheduled" :: String),
      String
"invited_emails" String -> [String] -> Pair
forall a. ToJSON a => String -> a -> Pair
.= [String]
invitedEmails
    ]

-- | Legacy (V15/V16) meeting JSON: carries @end_time@ and no @tzid@ (V17 adds
-- @tzid@). Used to exercise the legacy endpoints in interop tests.
defaultMeetingJsonLegacy :: String -> UTCTime -> UTCTime -> [String] -> Value
defaultMeetingJsonLegacy :: String -> UTCTime -> UTCTime -> [String] -> Value
defaultMeetingJsonLegacy String
title UTCTime
startTime UTCTime
endTime [String]
invitedEmails =
  [Pair] -> Value
object
    [ String
"title" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= String
title,
      String
"start_time" String -> UTCTime -> Pair
forall a. ToJSON a => String -> a -> Pair
.= UTCTime
startTime,
      String
"end_time" String -> UTCTime -> Pair
forall a. ToJSON a => String -> a -> Pair
.= UTCTime
endTime,
      String
"invited_emails" String -> [String] -> Pair
forall a. ToJSON a => String -> a -> Pair
.= [String]
invitedEmails
    ]

testMeetingGetNotFound :: (HasCallStack) => App ()
testMeetingGetNotFound :: HasCallStack => App ()
testMeetingGetNotFound = do
  (owner, _tid, _members) <- Domain -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam Domain
OwnDomain Int
1
  fakeMeetingId <- randomId

  getMeeting owner "example.com" fakeMeetingId >>= assertLabel 404 "meeting-not-found"

-- Test that disabled MeetingsConfig feature blocks creation
testMeetingsConfigDisabledBlocksCreate :: (HasCallStack) => App ()
testMeetingsConfigDisabledBlocksCreate :: HasCallStack => App ()
testMeetingsConfigDisabledBlocksCreate = do
  (owner, tid, _members) <- Domain -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam Domain
OwnDomain Int
1

  -- Disable the MeetingsConfig feature
  let firstMeeting = [Pair] -> Value
object [String
"status" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= String
"disabled", String
"lockStatus" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= String
"unlocked"]
  I.setTeamFeatureConfig owner tid "meetings" firstMeeting >>= assertStatus 200

  -- Try to create a meeting - should fail
  now <- liftIO getCurrentTime
  let startTime = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
3600 UTCTime
now
      endTime = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
7200 UTCTime
now
      newMeeting = String -> UTCTime -> UTCTime -> [String] -> Value
defaultMeetingJson String
"Team Standup" UTCTime
startTime UTCTime
endTime []

  postMeetings owner newMeeting >>= assertLabel 403 "invalid-op"

-- | Read endpoints (@GET /meetings/list@, @GET /meetings/{domain}/{id}@) treat a
-- team with the @meetings@ feature disabled as "no meetings" (list -> @200 []@,
-- get -> @404 meeting-not-found@) instead of @403 invalid-op@, while write
-- endpoints (@POST /meetings@) keep the hard gate and still return @403
-- invalid-op@. See WPB-27329.
testMeetingsReadsWhenDisabled :: (HasCallStack) => App ()
testMeetingsReadsWhenDisabled :: HasCallStack => App ()
testMeetingsReadsWhenDisabled = do
  (owner, tid, _members) <- Domain -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam Domain
OwnDomain Int
1
  now <- liftIO getCurrentTime
  let startTime = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
3600 UTCTime
now
      endTime = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
7200 UTCTime
now
      newMeeting = String -> UTCTime -> UTCTime -> [String] -> Value
defaultMeetingJson String
"test meeting" UTCTime
startTime UTCTime
endTime []

  -- Enabled (default): create a meeting to use as the read target later.
  meeting <- postMeetings owner newMeeting >>= getJSON 201
  (meetingId, domain) <- getMeetingIdAndDomain meeting

  -- Positive control while enabled: the created meeting is directly findable.
  getMeeting owner domain meetingId >>= assertStatus 200

  -- Disable the meetings feature for the team.
  let disabled = [Pair] -> Value
object [String
"status" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= String
"disabled", String
"lockStatus" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= String
"unlocked"]
  I.setTeamFeatureConfig owner tid "meetings" disabled >>= assertStatus 200

  -- Read paths treat a disabled feature as "no meetings": list -> 200 [], get -> 404.
  getMeetingsList owner `bindResponse` \Response
resp -> do
    Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
    meetings <- Response
resp.json Maybe Value -> (Maybe Value -> App [Value]) -> App [Value]
forall a b. a -> (a -> b) -> b
& Maybe Value -> App [Value]
forall a. (HasCallStack, MakesValue a) => a -> App [Value]
asList
    shouldBeEmpty meetings

  getMeeting owner domain meetingId >>= assertLabel 404 "meeting-not-found"

  -- Write paths keep the hard gate: create -> 403 invalid-op (unchanged behavior).
  postMeetings owner newMeeting >>= assertLabel 403 "invalid-op"

  -- Re-enable: the previously-created meeting is readable again.
  let enabled = [Pair] -> Value
object [String
"status" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= String
"enabled", String
"lockStatus" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= String
"unlocked"]
  I.setTeamFeatureConfig owner tid "meetings" enabled >>= assertStatus 200

  listResp2 <- getMeetingsList owner
  assertSuccess listResp2
  meetings2 <- listResp2.json & asList
  fetchedIds <- forM meetings2 $ \Value
m -> Value
m Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"qualified_id" App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"id" App Value -> (Value -> App String) -> App String
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString
  (meetingId `elem` fetchedIds) `shouldMatch` True

-- Test that creating a meeting with a start time in the past is rejected
testMeetingCreatePastStartTime :: (HasCallStack) => App ()
testMeetingCreatePastStartTime :: HasCallStack => App ()
testMeetingCreatePastStartTime = do
  (owner, _tid, _members) <- Domain -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam Domain
OwnDomain Int
1
  now <- liftIO getCurrentTime
  let startTime = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime (NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a
negate NominalDiffTime
3600) UTCTime
now
      endTime = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
3600 UTCTime
now
      newMeeting = String -> UTCTime -> UTCTime -> [String] -> Value
defaultMeetingJson String
"Past Meeting" UTCTime
startTime UTCTime
endTime []

  postMeetings owner newMeeting >>= assertLabel 403 "invalid-op"

testMeetingRecurrence :: (HasCallStack) => App ()
testMeetingRecurrence :: HasCallStack => App ()
testMeetingRecurrence = do
  (owner, _tid, _members) <- Domain -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam Domain
OwnDomain Int
1
  now <- liftIO getCurrentTime
  let startTime = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
3600 UTCTime
now
      endTime = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
7200 UTCTime
now
      recurrenceUntil = TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
Time.formatTime TimeLocale
Time.defaultTimeLocale String
"%FT%TZ" (UTCTime -> String) -> UTCTime -> String
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> UTCTime -> UTCTime
addUTCTime (NominalDiffTime
30 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
nominalDay) UTCTime
now -- format to avoid rounding expectation mismatch
      recurrence =
        [Pair] -> Value
object
          [ String
"frequency" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= String
"daily",
            String
"interval" String -> Int -> Pair
forall a. ToJSON a => String -> a -> Pair
.= (Int
1 :: Int),
            String
"until" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= String
recurrenceUntil
          ]
      newMeeting =
        [Pair] -> Value
object
          [ String
"title" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= String
"Daily Standup with Recurrence",
            String
"start_time" String -> UTCTime -> Pair
forall a. ToJSON a => String -> a -> Pair
.= UTCTime
startTime,
            String
"end_time" String -> UTCTime -> Pair
forall a. ToJSON a => String -> a -> Pair
.= UTCTime
endTime,
            String
"tzid" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= (String
"Europe/Berlin" :: String),
            String
"type" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= (String
"scheduled" :: String),
            String
"recurrence" String -> Value -> Pair
forall a. ToJSON a => String -> a -> Pair
.= Value
recurrence,
            String
"invited_emails" String -> [String] -> Pair
forall a. ToJSON a => String -> a -> Pair
.= [String
"charlie@example.com"]
          ]

  r1 <- postMeetings owner newMeeting
  assertSuccess r1

  meeting <- getJSON 201 r1
  (meetingId, domain) <- getMeetingIdAndDomain meeting
  let updatedRecurrence =
        [Pair] -> Value
object
          [ String
"frequency" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= String
"weekly",
            String
"interval" String -> Int -> Pair
forall a. ToJSON a => String -> a -> Pair
.= (Int
2 :: Int)
          ]
      updatedMeeting =
        [Pair] -> Value
object
          [ String
"title" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= String
"Updated Standup",
            String
"start_date" String -> UTCTime -> Pair
forall a. ToJSON a => String -> a -> Pair
.= UTCTime
startTime,
            String
"end_date" String -> UTCTime -> Pair
forall a. ToJSON a => String -> a -> Pair
.= UTCTime
endTime,
            String
"recurrence" String -> Value -> Pair
forall a. ToJSON a => String -> a -> Pair
.= Value
updatedRecurrence
          ]

  r2 <- withWebSocket owner $ \WebSocket
ws -> do
    resp <- Value -> String -> String -> Value -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> String -> String -> Value -> App Response
putMeeting Value
owner String
domain String
meetingId Value
updatedMeeting
    assertSuccess resp
    -- the creator's other client connection (this websocket) now receives meeting.update
    void $ awaitMatch isMeetingUpdateNotif ws
    pure resp

  updated <- getJSON 200 r2
  updated %. "title" `shouldMatch` ("Updated Standup" :: String)
  recurrence' <- updated %. "recurrence"
  recurrence' %. "frequency" `shouldMatch` "weekly"
  recurrence' %. "interval" `shouldMatchInt` 2

  -- The full conversation is still returned on update
  assertConversationMatchesLegacy updated

testMeetingUpdateNotFound :: (HasCallStack) => App ()
testMeetingUpdateNotFound :: HasCallStack => App ()
testMeetingUpdateNotFound = do
  (owner, _tid, _members) <- Domain -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam Domain
OwnDomain Int
1
  fakeMeetingId <- randomId
  now <- liftIO getCurrentTime
  let startTime = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
3600 UTCTime
now
      endTime = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
7200 UTCTime
now
      update =
        [Pair] -> Value
object
          [ String
"title" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= String
"Updated",
            String
"start_date" String -> UTCTime -> Pair
forall a. ToJSON a => String -> a -> Pair
.= UTCTime
startTime,
            String
"end_date" String -> UTCTime -> Pair
forall a. ToJSON a => String -> a -> Pair
.= UTCTime
endTime
          ]

  putMeeting owner "example.com" fakeMeetingId update >>= assertStatus 404

testMeetingUpdateUnauthorized :: (HasCallStack) => App ()
testMeetingUpdateUnauthorized :: HasCallStack => App ()
testMeetingUpdateUnauthorized = do
  (owner, _tid, _members) <- Domain -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam Domain
OwnDomain Int
1
  (otherUser, _, _membersOther) <- createTeam OwnDomain 1
  now <- liftIO getCurrentTime
  let startTime = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
3600 UTCTime
now
      endTime = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
7200 UTCTime
now
      newMeeting = String -> UTCTime -> UTCTime -> [String] -> Value
defaultMeetingJson String
"Team Standup" UTCTime
startTime UTCTime
endTime []

  r1 <- postMeetings owner newMeeting
  assertSuccess r1

  meeting <- getJSON 201 r1
  (meetingId, domain) <- getMeetingIdAndDomain meeting
  let update =
        [Pair] -> Value
object
          [ String
"title" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= String
"Hijacked",
            String
"start_date" String -> UTCTime -> Pair
forall a. ToJSON a => String -> a -> Pair
.= UTCTime
startTime,
            String
"end_date" String -> UTCTime -> Pair
forall a. ToJSON a => String -> a -> Pair
.= UTCTime
endTime
          ]

  putMeeting otherUser domain meetingId update >>= assertStatus 404

-- | WPB-28272: PUT /meetings/{domain}/{id} accepts an optional @tzid@ and
-- updates the stored time zone; omitting it (as legacy clients do) keeps the
-- stored value; an invalid tzid is rejected at decode time.
testMeetingUpdateTzid :: (HasCallStack) => App ()
testMeetingUpdateTzid :: HasCallStack => App ()
testMeetingUpdateTzid = do
  (owner, _tid, _members) <- Domain -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam Domain
OwnDomain Int
1
  now <- liftIO getCurrentTime
  let newMeeting = String -> UTCTime -> UTCTime -> [String] -> Value
defaultMeetingJson String
"Tzid Meeting" (NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
3600 UTCTime
now) (NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
7200 UTCTime
now) []
  meeting <- postMeetings owner newMeeting >>= getJSON 201
  (meetingId, domain) <- getMeetingIdAndDomain meeting
  meeting %. "tzid" `shouldMatch` ("Europe/Berlin" :: String)

  updated <- putMeeting owner domain meetingId (object ["tzid" .= ("America/New_York" :: String)]) >>= getJSON 200
  updated %. "tzid" `shouldMatch` ("America/New_York" :: String)
  updated %. "title" `shouldMatch` ("Tzid Meeting" :: String)

  fetched <- getMeeting owner domain meetingId >>= getJSON 200
  fetched %. "tzid" `shouldMatch` ("America/New_York" :: String)

  putMeeting owner domain meetingId (object ["title" .= ("Renamed" :: String)]) >>= assertStatus 200
  fetched2 <- getMeeting owner domain meetingId >>= getJSON 200
  fetched2 %. "tzid" `shouldMatch` ("America/New_York" :: String)
  fetched2 %. "title" `shouldMatch` ("Renamed" :: String)

  putMeeting owner domain meetingId (object ["tzid" .= ("not-a-zone" :: String)]) >>= assertLabel 400 "bad-request"

testMeetingListEmpty :: (HasCallStack) => App ()
testMeetingListEmpty :: HasCallStack => App ()
testMeetingListEmpty = do
  (owner, _tid, _members) <- Domain -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam Domain
OwnDomain Int
1
  resp <- getMeetingsList owner
  assertSuccess resp
  meetings <- resp.json & asList
  length (meetings :: [Value]) `shouldMatchInt` 0

testMeetingListNoMeetings :: (HasCallStack) => App ()
testMeetingListNoMeetings :: HasCallStack => App ()
testMeetingListNoMeetings = do
  (owner, _tid, _members) <- Domain -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam Domain
OwnDomain Int
1
  _ <- createTeam OwnDomain 1
  resp <- getMeetingsList owner
  assertSuccess resp
  meetings <- resp.json & asList
  length (meetings :: [Value]) `shouldMatchInt` 0

testMeetingListMultiple :: (HasCallStack) => App ()
testMeetingListMultiple :: HasCallStack => App ()
testMeetingListMultiple = do
  (owner, _tid, _members) <- Domain -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam Domain
OwnDomain Int
1
  now <- liftIO getCurrentTime
  let firstMeeting = String -> UTCTime -> UTCTime -> [String] -> Value
defaultMeetingJson String
"First Meeting" (NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
3600 UTCTime
now) (NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
7200 UTCTime
now) []
      secondMeeting = String -> UTCTime -> UTCTime -> [String] -> Value
defaultMeetingJson String
"Second Meeting" (NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
3600 UTCTime
now) (NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
7200 UTCTime
now) []
      thirdMeeting = String -> UTCTime -> UTCTime -> [String] -> Value
defaultMeetingJson String
"Third Meeting" (NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
3600 UTCTime
now) (NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
7200 UTCTime
now) []
  r1 <- postMeetings owner firstMeeting
  assertSuccess r1
  m1 <- getJSON 201 r1
  (id1, _) <- getMeetingIdAndDomain m1

  r2 <- postMeetings owner secondMeeting
  assertSuccess r2
  m2 <- getJSON 201 r2
  (id2, _) <- getMeetingIdAndDomain m2

  r3 <- postMeetings owner thirdMeeting
  assertSuccess r3
  m3 <- getJSON 201 r3
  (id3, _) <- getMeetingIdAndDomain m3

  resp <- getMeetingsList owner
  assertSuccess resp
  meetings <- resp.json & asList
  length (meetings :: [Value]) `shouldMatchInt` 3

  titles <- forM meetings $ \Value
m -> Value
m Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"title" App Value -> (Value -> App String) -> App String
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString
  let expectedTitles = [String
"First Meeting", String
"Second Meeting", String
"Third Meeting"]
  (all (`elem` titles) expectedTitles) `shouldMatch` True

  fetchedIds <- forM meetings $ \Value
m -> Value
m Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"qualified_id" App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"id" App Value -> (Value -> App String) -> App String
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString
  let expectedIds = [String
id1, String
id2, String
id3]
  (all (`elem` fetchedIds) expectedIds) `shouldMatch` True

testMeetingListPagination :: (HasCallStack) => App ()
testMeetingListPagination :: HasCallStack => App ()
testMeetingListPagination = do
  (owner, _tid, _members) <- Domain -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam Domain
OwnDomain Int
1
  now <- liftIO getCurrentTime

  -- The internal page size is 1000, so we create 1001 meetings to test pagination.
  -- This ensures `hasMore = True` is triggered and multiple pages are fetched.
  forM_ [(1 :: Int) .. 1001] $ \Int
i -> do
    let meeting :: Value
meeting = String -> UTCTime -> UTCTime -> [String] -> Value
defaultMeetingJson (String
"Meeting " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
i) (NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
3600 UTCTime
now) (NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
7200 UTCTime
now) []
    Value -> Value -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> Value -> App Response
postMeetings Value
owner Value
meeting App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
201

  resp <- getMeetingsList owner
  assertSuccess resp
  meetings <- resp.json & asList
  length (meetings :: [Value]) `shouldMatchInt` 1001

testMeetingAddInvitation :: (HasCallStack) => App ()
testMeetingAddInvitation :: HasCallStack => App ()
testMeetingAddInvitation = do
  (owner, _tid, _members) <- Domain -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam Domain
OwnDomain Int
1
  now <- liftIO getCurrentTime
  let startTime = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
3600 UTCTime
now
      endTime = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
7200 UTCTime
now
      newMeeting = String -> UTCTime -> UTCTime -> [String] -> Value
defaultMeetingJson String
"Team Standup" UTCTime
startTime UTCTime
endTime [String
"alice@example.com"]
  meeting <- postMeetings owner newMeeting >>= getJSON 201
  (meetingId, domain) <- getMeetingIdAndDomain meeting
  let invitation = [Pair] -> Value
object [String
"emails" String -> [String] -> Pair
forall a. ToJSON a => String -> a -> Pair
.= [String
"bob@example.com"]]
  postMeetingInvitation owner domain meetingId invitation >>= assertStatus 200
  updated <- getMeeting owner domain meetingId >>= getJSON 200
  updated %. "invited_emails" `shouldMatch` ["alice@example.com", "bob@example.com"]

testMeetingAddInvitationNotFound :: (HasCallStack) => App ()
testMeetingAddInvitationNotFound :: HasCallStack => App ()
testMeetingAddInvitationNotFound = do
  (owner, _tid, _members) <- Domain -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam Domain
OwnDomain Int
1
  fakeMeetingId <- randomId
  let invitation = [Pair] -> Value
object [String
"emails" String -> [String] -> Pair
forall a. ToJSON a => String -> a -> Pair
.= [String
"bob@example.com"]]
  postMeetingInvitation owner "example.com" fakeMeetingId invitation >>= assertStatus 404

testMeetingRemoveInvitation :: (HasCallStack) => App ()
testMeetingRemoveInvitation :: HasCallStack => App ()
testMeetingRemoveInvitation = do
  (owner, _tid, _members) <- Domain -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam Domain
OwnDomain Int
1
  now <- liftIO getCurrentTime
  let startTime = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
3600 UTCTime
now
      endTime = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
7200 UTCTime
now
      newMeeting = String -> UTCTime -> UTCTime -> [String] -> Value
defaultMeetingJson String
"Team Standup" UTCTime
startTime UTCTime
endTime [String
"alice@example.com", String
"bob@example.com"]

  meeting <- postMeetings owner newMeeting >>= getJSON 201
  (meetingId, domain) <- getMeetingIdAndDomain meeting
  let removeInvitation = [Pair] -> Value
object [String
"emails" String -> [String] -> Pair
forall a. ToJSON a => String -> a -> Pair
.= [String
"alice@example.com"]]

  deleteMeetingInvitation owner domain meetingId removeInvitation >>= assertStatus 200

  updated <- getMeeting owner domain meetingId >>= getJSON 200
  updated %. "invited_emails" `shouldMatch` ["bob@example.com"]

testMeetingRemoveInvitationNotFound :: (HasCallStack) => App ()
testMeetingRemoveInvitationNotFound :: HasCallStack => App ()
testMeetingRemoveInvitationNotFound = do
  (owner, _tid, _members) <- Domain -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam Domain
OwnDomain Int
1
  fakeMeetingId <- randomId
  let removeInvitation = [Pair] -> Value
object [String
"emails" String -> [String] -> Pair
forall a. ToJSON a => String -> a -> Pair
.= [String
"alice@example.com"]]

  deleteMeetingInvitation owner "example.com" fakeMeetingId removeInvitation >>= assertStatus 404

testMeetingReplaceInvitation :: (HasCallStack) => App ()
testMeetingReplaceInvitation :: HasCallStack => App ()
testMeetingReplaceInvitation = do
  (owner, _tid, _members) <- Domain -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam Domain
OwnDomain Int
1
  now <- liftIO getCurrentTime
  let startTime = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
3600 UTCTime
now
      endTime = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
7200 UTCTime
now
      newMeeting = String -> UTCTime -> UTCTime -> [String] -> Value
defaultMeetingJson String
"Team Standup" UTCTime
startTime UTCTime
endTime [String
"alice@example.com", String
"bob@example.com"]

  meeting <- postMeetings owner newMeeting >>= getJSON 201
  (meetingId, domain) <- getMeetingIdAndDomain meeting
  let invitation = [Pair] -> Value
object [String
"emails" String -> [String] -> Pair
forall a. ToJSON a => String -> a -> Pair
.= [String
"charlie@example.com"]]
  putMeetingInvitation owner domain meetingId invitation >>= assertStatus 200
  updated <- getMeeting owner domain meetingId >>= getJSON 200
  updated %. "invited_emails" `shouldMatch` ["charlie@example.com"]

testMeetingReplaceInvitationEmpty :: (HasCallStack) => App ()
testMeetingReplaceInvitationEmpty :: HasCallStack => App ()
testMeetingReplaceInvitationEmpty = do
  (owner, _tid, _members) <- Domain -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam Domain
OwnDomain Int
1
  now <- liftIO getCurrentTime
  let startTime = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
3600 UTCTime
now
      endTime = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
7200 UTCTime
now
      newMeeting = String -> UTCTime -> UTCTime -> [String] -> Value
defaultMeetingJson String
"Team Standup" UTCTime
startTime UTCTime
endTime [String
"alice@example.com", String
"bob@example.com"]

  meeting <- postMeetings owner newMeeting >>= getJSON 201
  (meetingId, domain) <- getMeetingIdAndDomain meeting
  let invitation = [Pair] -> Value
object [String
"emails" String -> [String] -> Pair
forall a. ToJSON a => String -> a -> Pair
.= ([] :: [String])]
  putMeetingInvitation owner domain meetingId invitation >>= assertStatus 200
  updated <- getMeeting owner domain meetingId >>= getJSON 200
  updated %. "invited_emails" `shouldMatch` ([] :: [String])

testMeetingReplaceInvitationNotFound :: (HasCallStack) => App ()
testMeetingReplaceInvitationNotFound :: HasCallStack => App ()
testMeetingReplaceInvitationNotFound = do
  (owner, _tid, _members) <- Domain -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam Domain
OwnDomain Int
1
  fakeMeetingId <- randomId
  let invitation = [Pair] -> Value
object [String
"emails" String -> [String] -> Pair
forall a. ToJSON a => String -> a -> Pair
.= [String
"bob@example.com"]]
  putMeetingInvitation owner "example.com" fakeMeetingId invitation >>= assertStatus 404

testMeetingReplaceInvitationUnauthorized :: (HasCallStack) => App ()
testMeetingReplaceInvitationUnauthorized :: HasCallStack => App ()
testMeetingReplaceInvitationUnauthorized = do
  (owner, _tid, _members) <- Domain -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam Domain
OwnDomain Int
1
  (otherUser, _, _) <- createTeam OwnDomain 1
  now <- liftIO getCurrentTime
  let startTime = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
3600 UTCTime
now
      endTime = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
7200 UTCTime
now
      newMeeting = String -> UTCTime -> UTCTime -> [String] -> Value
defaultMeetingJson String
"Team Standup" UTCTime
startTime UTCTime
endTime [String
"alice@example.com"]

  meeting <- postMeetings owner newMeeting >>= getJSON 201
  (meetingId, domain) <- getMeetingIdAndDomain meeting
  let invitation = [Pair] -> Value
object [String
"emails" String -> [String] -> Pair
forall a. ToJSON a => String -> a -> Pair
.= [String
"eve@example.com"]]
  putMeetingInvitation otherUser domain meetingId invitation >>= assertStatus 404

testMeetingDelete :: (HasCallStack) => App ()
testMeetingDelete :: HasCallStack => App ()
testMeetingDelete = do
  (owner, _tid, _members) <- Domain -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam Domain
OwnDomain Int
1
  now <- liftIO getCurrentTime
  let startTime = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
3600 UTCTime
now
      endTime = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
7200 UTCTime
now
      recurrenceUntil = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime (NominalDiffTime
30 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
24 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
3600) UTCTime
now
      recurrence =
        [Pair] -> Value
object
          [ String
"frequency" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= String
"daily",
            String
"interval" String -> Int -> Pair
forall a. ToJSON a => String -> a -> Pair
.= (Int
1 :: Int),
            String
"until" String -> UTCTime -> Pair
forall a. ToJSON a => String -> a -> Pair
.= UTCTime
recurrenceUntil
          ]
      newMeeting =
        [Pair] -> Value
object
          [ String
"title" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= String
"Team Standup",
            String
"start_time" String -> UTCTime -> Pair
forall a. ToJSON a => String -> a -> Pair
.= UTCTime
startTime,
            String
"end_time" String -> UTCTime -> Pair
forall a. ToJSON a => String -> a -> Pair
.= UTCTime
endTime,
            String
"type" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= (String
"scheduled" :: String),
            String
"tzid" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= (String
"Europe/Berlin" :: String),
            String
"invited_emails" String -> [String] -> Pair
forall a. ToJSON a => String -> a -> Pair
.= ([] :: [String]),
            String
"recurrence" String -> Value -> Pair
forall a. ToJSON a => String -> a -> Pair
.= Value
recurrence
          ]
  r1 <- postMeetings owner newMeeting
  assertSuccess r1
  meeting <- getJSON 201 r1
  (meetingId, domain) <- getMeetingIdAndDomain meeting
  withWebSocket owner $ \WebSocket
ws -> do
    Value -> String -> String -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> String -> String -> App Response
deleteMeeting Value
owner String
domain String
meetingId App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
200
    -- meeting.delete is sent before the conversation is deleted (WPB-29046):
    -- await both notifications and assert their arrival order.
    [firstDel, secondDel] <-
      HasCallStack =>
Int -> (Value -> App Bool) -> WebSocket -> App [Value]
Int -> (Value -> App Bool) -> WebSocket -> App [Value]
awaitNMatches
        Int
2
        (\Value
n -> Value -> App Bool
forall a. (HasCallStack, MakesValue a) => a -> App Bool
isMeetingDeleteNotif Value
n App Bool -> App Bool -> App Bool
||~ Value -> App Bool
forall a. (HasCallStack, MakesValue a) => a -> App Bool
isConvDeleteMeetingNotif Value
n)
        WebSocket
ws
    assertBool "expected meeting.delete before conversation.delete-meeting" =<< isMeetingDeleteNotif firstDel
    assertBool "expected conversation.delete-meeting after meeting.delete" =<< isConvDeleteMeetingNotif secondDel
  getMeeting owner domain meetingId >>= assertStatus 404

-- | WPB-27907: meeting lifecycle events are delivered to all conversation
-- members; only the originating client connection is excluded (no redundant
-- echo), while the initiator's other client connections and all other members
-- receive them. This test covers the non-initiator member path: a member who
-- joined the meeting conversation after creation receives 'meeting.update' and
-- 'meeting.delete'. The originating-client-connection exclusion is covered in
-- 'testMeetingOriginatingConnectionExcluded'; the multi-member recipient set
-- is covered at the unit level in "Wire.MeetingsSubsystem.InterpreterSpec".
testMeetingLifecycleEventsDeliveredToMembers :: (HasCallStack) => App ()
testMeetingLifecycleEventsDeliveredToMembers :: HasCallStack => App ()
testMeetingLifecycleEventsDeliveredToMembers = do
  (owner, _tid, [participant]) <- Domain -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam Domain
OwnDomain Int
2
  ownerClient <- createMLSClient def owner
  participantClient <- createMLSClient def participant
  _ <- uploadNewKeyPackage def participantClient
  now <- liftIO getCurrentTime
  let startTime = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
3600 UTCTime
now
      endTime = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
7200 UTCTime
now
      newMeeting = String -> UTCTime -> UTCTime -> [String] -> Value
defaultMeetingJson String
"Lifecycle Meeting" UTCTime
startTime UTCTime
endTime []

  meeting <- postMeetings owner newMeeting >>= getJSON 201
  (meetingId, domain) <- getMeetingIdAndDomain meeting

  -- Add the second team member to the meeting conversation via MLS, so that
  -- they are among the recipients of subsequent lifecycle events.
  convQid <- meeting %. "qualified_conversation"
  conv <- getConversation owner convQid >>= getJSON 200
  convId <- objConvId conv
  createGroup def ownerClient convId
  void $ createAddCommit ownerClient convId [participant] >>= sendAndConsumeCommitBundle

  -- The non-initiator member receives 'meeting.update'; the originating-
  -- client-connection exclusion is asserted in 'testMeetingOriginatingConnectionExcluded'.
  updateNotif <-
    withWebSocket participant $ \WebSocket
ws -> do
      Value -> String -> String -> Value -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> String -> String -> Value -> App Response
putMeeting Value
owner String
domain String
meetingId ([Pair] -> Value
object [String
"title" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= String
"Updated Lifecycle Meeting"]) App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Response -> App ()
Response -> App ()
assertSuccess
      HasCallStack => (Value -> App Bool) -> WebSocket -> App Value
(Value -> App Bool) -> WebSocket -> App Value
awaitMatch Value -> App Bool
forall a. (HasCallStack, MakesValue a) => a -> App Bool
isMeetingUpdateNotif WebSocket
ws
  assertMeetingNotif updateNotif (meeting %. "qualified_id")

  -- The non-initiator member receives 'meeting.delete'. The subsequent
  -- 'conversation.delete-meeting' event is expected and skipped by 'awaitMatch'.
  deleteNotif <-
    withWebSocket participant $ \WebSocket
ws -> do
      Value -> String -> String -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> String -> String -> App Response
deleteMeeting Value
owner String
domain String
meetingId App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
200
      HasCallStack => (Value -> App Bool) -> WebSocket -> App Value
(Value -> App Bool) -> WebSocket -> App Value
awaitMatch Value -> App Bool
forall a. (HasCallStack, MakesValue a) => a -> App Bool
isMeetingDeleteNotif WebSocket
ws
  assertMeetingNotif deleteNotif (meeting %. "qualified_id")

testMeetingOriginatingConnectionExcluded :: (HasCallStack) => App ()
testMeetingOriginatingConnectionExcluded :: HasCallStack => App ()
testMeetingOriginatingConnectionExcluded = do
  (owner, _tid, _members) <- Domain -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam Domain
OwnDomain Int
1
  now <- liftIO getCurrentTime
  let newMeeting = String -> UTCTime -> UTCTime -> [String] -> Value
defaultMeetingJson String
"Origin Conn" (NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
3600 UTCTime
now) (NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
7200 UTCTime
now) []
  withWebSocket (owner, "conn") $ \WebSocket
wsOrigin ->
    Value -> (WebSocket -> App ()) -> App ()
forall w a.
(HasCallStack, ToWSConnect w) =>
w -> (WebSocket -> App a) -> App a
withWebSocket Value
owner ((WebSocket -> App ()) -> App ())
-> (WebSocket -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \WebSocket
wsOther -> do
      _ <- Value -> Value -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> Value -> App Response
postMeetings Value
owner Value
newMeeting App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Response -> App ()
Response -> App ()
assertSuccess
      void $ awaitMatch isMeetingCreateNotif wsOther
      -- The originating client connection still receives conversation.create-meeting
      -- (the conversation event is not client-connection-excluded), but it must NOT
      -- receive meeting.create (excluded via the request's client connection "conn").
      void $ awaitMatch isConvCreateMeetingNotif wsOrigin
      assertNoEvent 1 wsOrigin

testMeetingDeleteNotFound :: (HasCallStack) => App ()
testMeetingDeleteNotFound :: HasCallStack => App ()
testMeetingDeleteNotFound = do
  (owner, _tid, _members) <- Domain -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam Domain
OwnDomain Int
1
  fakeMeetingId <- randomId
  deleteMeeting owner "example.com" fakeMeetingId >>= assertStatus 404

testMeetingDeleteUnauthorized :: (HasCallStack) => App ()
testMeetingDeleteUnauthorized :: HasCallStack => App ()
testMeetingDeleteUnauthorized = do
  (owner, _tid, _members) <- Domain -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam Domain
OwnDomain Int
1
  (otherUser, _, _membersOther) <- createTeam OwnDomain 1
  now <- liftIO getCurrentTime
  let startTime = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
3600 UTCTime
now
      endTime = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
7200 UTCTime
now
      newMeeting = String -> UTCTime -> UTCTime -> [String] -> Value
defaultMeetingJson String
"Team Standup" UTCTime
startTime UTCTime
endTime []
  r1 <- postMeetings owner newMeeting
  assertSuccess r1
  meeting <- getJSON 201 r1
  (meetingId, domain) <- getMeetingIdAndDomain meeting
  deleteMeeting otherUser domain meetingId >>= assertStatus 404

testMeetingCleanup :: (HasCallStack) => App ()
testMeetingCleanup :: HasCallStack => App ()
testMeetingCleanup = do
  env <- App Env
forall r (m :: * -> *). MonadReader r m => m r
ask
  timedOutResult <- liftIO $ timeout (2 * 60 * 1_000_000) $ runAppWithEnv env $ do
    -- 2 minutes timeout
    (owner, _tid, _members) <- createTeam OwnDomain 1
    now <- liftIO getCurrentTime
    -- Create a meeting that starts now and ends 1s later.
    -- Configured retention is 0.0014 hours (~5 seconds).
    -- cutoffTime will be now' - 5s.
    -- We need end_date < cutoffTime.
    -- If we wait 7 seconds, now' = now + 7s.
    -- cutoffTime = now + 7s - 5s = now + 2s.
    -- end_date (now + 1s) < cutoffTime (now + 2s).
    let startTime = UTCTime
now
        endTime = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
1 UTCTime
now
        newMeeting = String -> UTCTime -> UTCTime -> [String] -> Value
defaultMeetingJson String
"Cleanup Test" UTCTime
startTime UTCTime
endTime []

    r1 <- postMeetings owner newMeeting
    assertSuccess r1
    meeting <- getJSON 201 r1
    (meetingId, domain) <- getMeetingIdAndDomain meeting

    -- Wait 7 seconds to ensure meeting is old enough
    liftIO $ threadDelay 7_000_000

    -- Wait for cleanup job to run
    waitForCleanupJob OwnDomain

    -- Check it's gone
    getMeeting owner domain meetingId >>= assertStatus 404

  case timedOutResult of
    Just () -> () -> App ()
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Maybe ()
Nothing -> String -> App ()
forall a. HasCallStack => String -> App a
assertFailure String
"testMeetingCleanup timed out after 2 minutes"

waitForCleanupJob :: (HasCallStack, MakesValue domain) => domain -> App ()
waitForCleanupJob :: forall domain.
(HasCallStack, MakesValue domain) =>
domain -> App ()
waitForCleanupJob domain
domain = do
  initialMetrics <- domain -> App String
forall {domain}. MakesValue domain => domain -> App String
getMetricsBody domain
domain
  let initialCount = String -> Integer
forall {source1}.
RegexContext Regex source1 (String, String, String, [String]) =>
source1 -> Integer
getRunCount String
initialMetrics

  waitForIncrease domain initialCount
  where
    getMetricsBody :: domain -> App String
getMetricsBody domain
d = do
      domain -> Service -> App Response
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Service -> App Response
getMetrics domain
d Service
BackgroundWorker App Response -> (Response -> App String) -> App String
forall a.
HasCallStack =>
App Response -> (Response -> App a) -> App a
`bindResponse` \Response
resp -> do
        Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
        String -> App String
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> App String) -> String -> App String
forall a b. (a -> b) -> a -> b
$ Text -> String
Text.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
Text.decodeUtf8 Response
resp.body

    getRunCount :: source1 -> Integer
getRunCount source1
metrics =
      let (String
_, String
_, String
_, [String]
matches) :: (String, String, String, [String]) =
            source1
metrics source1 -> String -> (String, String, String, [String])
forall source source1 target.
(RegexMaker Regex CompOption ExecOption source,
 RegexContext Regex source1 target) =>
source1 -> source -> target
=~ String
"wire_meetings_cleanup_runs_total ([0-9]+(\\.[0-9]+)?)"
       in case [String]
matches of
            [String
val, String
_] -> forall a b. (RealFrac a, Integral b) => a -> b
floor @_ @Integer (forall a. Read a => String -> a
read @Double String
val)
            [String]
_ -> Integer
0

    waitForIncrease :: t -> Integer -> App ()
waitForIncrease t
d Integer
oldVal = do
      metrics <- t -> App String
forall {domain}. MakesValue domain => domain -> App String
getMetricsBody t
d
      let newVal = String -> Integer
forall {source1}.
RegexContext Regex source1 (String, String, String, [String]) =>
source1 -> Integer
getRunCount String
metrics
      -- We wait until it increases.
      -- Note: if oldVal was 0 (metric didn't exist), getting 0 again means it hasn't run.
      -- If it runs, it should become >= 1.
      -- But wait, if matches is empty, we return 0.
      -- If the metric appears, it will be >= 1 (initialized at 0? Counter starts at 0).
      -- If it runs, it increments.
      when (newVal <= oldVal) $ do
        liftIO $ threadDelay 1_000_000 -- Wait 1s
        waitForIncrease d oldVal

testMeetingExpiration :: (HasCallStack) => App ()
testMeetingExpiration :: HasCallStack => App ()
testMeetingExpiration = do
  (owner, _tid, _members) <- Domain -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam Domain
OwnDomain Int
1
  now <- liftIO getCurrentTime
  let startTime = UTCTime
now
      -- meetingValidityPeriodSeconds is configured to 5 seconds in galley.integration.yaml
      endTime = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
1 UTCTime
now
      newMeeting = String -> UTCTime -> UTCTime -> [String] -> Value
defaultMeetingJson String
"Expiring Meeting" UTCTime
startTime UTCTime
endTime []

  r1 <- postMeetings owner newMeeting
  assertSuccess r1
  meeting <- getJSON 201 r1
  (meetingId, domain) <- getMeetingIdAndDomain meeting

  -- Check it is accessible immediately (endTime = now+1, well within the 5s validity)
  getMeeting owner domain meetingId >>= assertStatus 200

  -- Wait 7 seconds so endTime (now+1) is past the validity cutoff (now+7-5 = now+2)
  liftIO $ threadDelay 7_000_000

  -- Check it is expired
  getMeeting owner domain meetingId >>= assertStatus 404

-- A recurring meeting whose original time slot has passed but whose
-- recurrence window is still open must remain visible in the list (and via
-- get-meeting) after the meeting validity period elapses.
testMeetingListRecurringNotExpired :: (HasCallStack) => App ()
testMeetingListRecurringNotExpired :: HasCallStack => App ()
testMeetingListRecurringNotExpired = do
  (owner, _tid, _members) <- Domain -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam Domain
OwnDomain Int
1
  now <- liftIO getCurrentTime
  -- startTime = now, endTime = now+1: the slot only becomes "past" after the
  -- threadDelay below; the recurrence window stays open for 30 days.
  -- meetingValidityPeriodSeconds is 5s in galley.integration.yaml.
  let startTime = UTCTime
now
      endTime = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
1 UTCTime
now
      recurrenceUntil = TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
Time.formatTime TimeLocale
Time.defaultTimeLocale String
"%FT%TZ" (UTCTime -> String) -> UTCTime -> String
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> UTCTime -> UTCTime
addUTCTime (NominalDiffTime
30 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
nominalDay) UTCTime
now
      recurrence =
        [Pair] -> Value
object
          [ String
"frequency" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= String
"daily",
            String
"interval" String -> Int -> Pair
forall a. ToJSON a => String -> a -> Pair
.= (Int
1 :: Int),
            String
"until" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= String
recurrenceUntil
          ]
      newMeeting =
        [Pair] -> Value
object
          [ String
"title" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= String
"Recurring Past Meeting",
            String
"start_time" String -> UTCTime -> Pair
forall a. ToJSON a => String -> a -> Pair
.= UTCTime
startTime,
            String
"type" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= (String
"scheduled" :: String),
            String
"end_time" String -> UTCTime -> Pair
forall a. ToJSON a => String -> a -> Pair
.= UTCTime
endTime,
            String
"tzid" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= (String
"Europe/Berlin" :: String),
            String
"recurrence" String -> Value -> Pair
forall a. ToJSON a => String -> a -> Pair
.= Value
recurrence,
            String
"invited_emails" String -> [String] -> Pair
forall a. ToJSON a => String -> a -> Pair
.= ([] :: [String])
          ]

  meeting <- postMeetings owner newMeeting >>= getJSON 201
  (meetingId, domain) <- getMeetingIdAndDomain meeting

  -- Wait 7s beyond the validity period so a non-recurring meeting would expire.
  liftIO $ threadDelay 7_000_000

  -- Still accessible directly.
  getMeeting owner domain meetingId >>= assertStatus 200

  -- Still listed.
  resp <- getMeetingsList owner
  assertSuccess resp
  meetings <- resp.json & asList
  length meetings `shouldMatchInt` 1

-- | A meeting created via the V19 shape (@end_time + tzid + type@) is visible
-- to legacy clients (< V17) with an @end_time@; V19 reads carry @end_time@ too.
testMeetingInteropNewToLegacy :: (HasCallStack) => App ()
testMeetingInteropNewToLegacy :: HasCallStack => App ()
testMeetingInteropNewToLegacy = do
  (owner, _tid, _members) <- Domain -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam Domain
OwnDomain Int
1
  now <- liftIO getCurrentTime
  let startTime = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
3600 UTCTime
now
      endTime = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
3600 UTCTime
startTime
      newMeeting = String -> UTCTime -> UTCTime -> [String] -> Value
defaultMeetingJson String
"Interop New" UTCTime
startTime UTCTime
endTime []
  meeting <- postMeetings owner newMeeting >>= getJSON 201
  -- V19 read shape: carries end_time + tzid.
  startV17 <- meeting %. "start_time" >>= asString
  endV17 <- meeting %. "end_time" >>= asString
  startT <- assertJust ("could not parse start_time: " <> startV17) $ iso8601ParseM @Maybe @UTCTime startV17
  endT <- assertJust ("could not parse end_time: " <> endV17) $ iso8601ParseM @Maybe @UTCTime endV17
  -- end_time - start_time == 3600s regardless of client/server clock skew; both
  -- come back from Postgres at microsecond precision.
  endT `shouldMatch` addUTCTime 3600 startT
  tzid <- meeting %. "tzid" >>= asString
  tzid `shouldMatch` ("Europe/Berlin" :: String)
  -- A meeting whose end is 1h after start (formerly sent as "1h") still reads
  -- back with end_time = start_time + 3600s on the legacy path.
  let startTime2 = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
7200 UTCTime
now
      endTime2 = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
3600 UTCTime
startTime2
      newMeeting2 = String -> UTCTime -> UTCTime -> [String] -> Value
defaultMeetingJson String
"Interop New (1h)" UTCTime
startTime2 UTCTime
endTime2 []
  meeting2 <- postMeetings owner newMeeting2 >>= getJSON 201
  (meetingId2, domain2) <- getMeetingIdAndDomain meeting2
  legacy2 <- getMeetingV 16 owner domain2 meetingId2 >>= getJSON 200
  start2Str <- legacy2 %. "start_time" >>= asString
  end2Str <- legacy2 %. "end_time" >>= asString
  start2T <- assertJust ("could not parse start_time: " <> start2Str) $ iso8601ParseM @Maybe @UTCTime start2Str
  end2T <- assertJust ("could not parse end_time: " <> end2Str) $ iso8601ParseM @Maybe @UTCTime end2Str
  end2T `shouldMatch` addUTCTime 3600 start2T

-- | A meeting created via the legacy shape (@end_time@) is visible to V19
-- clients with @end_time@ and the injected default @tzid@ (Europe/Berlin).
testMeetingInteropLegacyToNew :: (HasCallStack) => App ()
testMeetingInteropLegacyToNew :: HasCallStack => App ()
testMeetingInteropLegacyToNew = do
  (owner, _tid, _members) <- Domain -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam Domain
OwnDomain Int
1
  now <- liftIO getCurrentTime
  let startTime = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
3600 UTCTime
now
      endTime = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
7200 UTCTime
now
      newMeeting = String -> UTCTime -> UTCTime -> [String] -> Value
defaultMeetingJsonLegacy String
"Interop Legacy" UTCTime
startTime UTCTime
endTime []
  meeting <- postMeetingsV 16 owner newMeeting >>= getJSON 201
  (meetingId, domain) <- getMeetingIdAndDomain meeting
  -- V19 read shape: end_time is present, tzid is the injected default.
  modern <- getMeeting owner domain meetingId >>= getJSON 200
  startStr <- modern %. "start_time" >>= asString
  endStr <- modern %. "end_time" >>= asString
  startT <- assertJust ("could not parse start_time: " <> startStr) $ iso8601ParseM @Maybe @UTCTime startStr
  endT <- assertJust ("could not parse end_time: " <> endStr) $ iso8601ParseM @Maybe @UTCTime endStr
  endT `shouldMatch` addUTCTime 3600 startT
  tzid <- modern %. "tzid" >>= asString
  tzid `shouldMatch` ("Europe/Berlin" :: String)

-- | The V19 meeting object exposes a @type@ field
-- (@immediate@ or @scheduled@); type is required on create and not updatable.
testMeetingType :: (HasCallStack) => App ()
testMeetingType :: HasCallStack => App ()
testMeetingType = do
  (owner, _tid, _members) <- Domain -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam Domain
OwnDomain Int
1
  now <- liftIO getCurrentTime
  let startTime = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
3600 UTCTime
now
      endTime = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
7200 UTCTime
now
      newMeeting =
        [Pair] -> Value
object
          [ String
"title" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= (String
"Typed Meeting" :: String),
            String
"start_time" String -> UTCTime -> Pair
forall a. ToJSON a => String -> a -> Pair
.= UTCTime
startTime,
            String
"end_time" String -> UTCTime -> Pair
forall a. ToJSON a => String -> a -> Pair
.= UTCTime
endTime,
            String
"tzid" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= (String
"Europe/Berlin" :: String),
            String
"type" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= (String
"immediate" :: String),
            String
"invited_emails" String -> [String] -> Pair
forall a. ToJSON a => String -> a -> Pair
.= ([] :: [String])
          ]
  meeting <- postMeetings owner newMeeting >>= getJSON 201
  (meetingId, domain) <- getMeetingIdAndDomain meeting
  fetched <- getMeeting owner domain meetingId >>= getJSON 200
  mtype <- fetched %. "type" >>= asString
  mtype `shouldMatch` ("immediate" :: String)

  -- The type is set at creation and cannot be changed (WPB-29119): an
  -- update carrying only @type@ decodes to an empty update and is rejected.
  putMeeting owner domain meetingId (object ["type" .= ("scheduled" :: String)]) >>= assertLabel 403 "invalid-op"
  unchanged <- getMeeting owner domain meetingId >>= getJSON 200
  unchangedType <- unchanged %. "type" >>= asString
  unchangedType `shouldMatch` ("immediate" :: String)

  -- V18-pinned reads carry no @type@ field.
  legacy <- getMeetingV 18 owner domain meetingId >>= getJSON 200
  assertFieldMissing legacy "type"

  -- An unknown type is rejected at decode time.
  let badMeeting =
        [Pair] -> Value
object
          [ String
"title" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= (String
"Typed Meeting" :: String),
            String
"start_time" String -> UTCTime -> Pair
forall a. ToJSON a => String -> a -> Pair
.= UTCTime
startTime,
            String
"end_time" String -> UTCTime -> Pair
forall a. ToJSON a => String -> a -> Pair
.= UTCTime
endTime,
            String
"tzid" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= (String
"Europe/Berlin" :: String),
            String
"type" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= (String
"urgent" :: String),
            String
"invited_emails" String -> [String] -> Pair
forall a. ToJSON a => String -> a -> Pair
.= ([] :: [String])
          ]
  postMeetings owner badMeeting >>= assertStatus 400

-- | WPB-28987: the V19 meeting object exposes an optional @link@ join link
-- carrying the meeting's join code as @key@/@code@ query parameters; it is
-- present only when the meeting has a live join code. Legacy endpoint shapes
-- are unchanged.
testMeetingLink :: (HasCallStack) => App ()
testMeetingLink :: HasCallStack => App ()
testMeetingLink = do
  (owner, _tid, _members) <- Domain -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam Domain
OwnDomain Int
1
  now <- liftIO getCurrentTime
  let startTime = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
3600 UTCTime
now
      endTime = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
7200 UTCTime
now
      newMeeting = String -> UTCTime -> UTCTime -> [String] -> Value
defaultMeetingJson String
"Linked Meeting" UTCTime
startTime UTCTime
endTime []
  meeting <- postMeetings owner newMeeting >>= getJSON 201
  (meetingId, domain) <- getMeetingIdAndDomain meeting
  -- The link is present iff a join-link URI is configured for the user's
  -- domain AND the code store can hold meeting codes (they are Postgres-only,
  -- so dualwrite serves links too); otherwise it is omitted.
  cfg <- readServiceConfig Galley
  codeStorage <- cfg %. "postgresMigration.conversationCodes" >>= asString
  -- Mirror 'MeetingsSubsystem.Interpreter.codeURIBase': single-ingress
  -- 'conversationCodeURI' first, then the per-domain 'multiIngress' entry;
  -- a Null value counts as unset.
  mBase <- do
    mSingle <- lookupField cfg "settings.conversationCodeURI" >>= maybe (pure Nothing) asStringM
    case mSingle of
      Just String
uri -> Maybe String -> App (Maybe String)
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Maybe String
forall a. a -> Maybe a
Just String
uri)
      Maybe String
Nothing -> do
        mMulti <- Value -> String -> App (Maybe Value)
forall a.
(HasCallStack, MakesValue a) =>
a -> String -> App (Maybe Value)
lookupField Value
cfg String
"settings.multiIngress"
        ownDomain <- asString OwnDomain
        maybe (pure Nothing) (`lookupField` ownDomain) mMulti >>= maybe (pure Nothing) asStringM
  -- Mirror 'API.mkMeetingLink', which rewrites the base's @conversation-join@
  -- suffix to @meeting-join@ and appends the code key, the live join-code
  -- value and the domain as query parameters.
  let supportsMeetingCodes = String
codeStorage String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"cassandra"
      meetingBase String
b =
        let normalized :: String
normalized = if String
"/" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` String
b then String -> String
forall a. HasCallStack => [a] -> [a]
init String
b else String
b
         in if String
"/conversation-join" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` String
normalized
              then Int -> String -> String
forall a. Int -> [a] -> [a]
take (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
normalized Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (String
"/conversation-join" :: String)) String
normalized String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"/meeting-join"
              else String
normalized
  case (mBase, supportsMeetingCodes) of
    (Just String
baseURI, Bool
True) -> do
      link <- Value
meeting Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"link" App Value -> (Value -> App String) -> App String
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString
      let expected = String -> String
meetingBase String
baseURI String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"/\\?key=[A-Za-z0-9_-]{20}&code=[A-Za-z0-9_-]{6,20}&domain=" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
domain
      assertBool ("unexpected meeting link: " <> link) (link =~ expected)

      fetched <- getMeeting owner domain meetingId >>= getJSON 200
      fetchedLink <- fetched %. "link" >>= asString
      assertBool ("unexpected fetched meeting link: " <> fetchedLink) (fetchedLink =~ expected)

      listResp <- getMeetingsList owner
      assertSuccess listResp
      meetingsList <- listResp.json & asList
      listedLink <- head meetingsList %. "link" >>= asString
      assertBool ("unexpected listed meeting link: " <> listedLink) (listedLink =~ expected)
    (Maybe String, Bool)
_ -> do
      -- Either no join-link URI is configured for the user's domain, or the
      -- code store cannot hold meeting codes; the link field is omitted.
      Value -> String -> App ()
forall a. (HasCallStack, MakesValue a) => a -> String -> App ()
assertFieldMissing Value
meeting String
"link"
      fetched <- Value -> String -> String -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> String -> String -> App Response
getMeeting Value
owner String
domain String
meetingId App Response -> (Response -> App Value) -> App Value
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App Value
Int -> Response -> App Value
getJSON Int
200
      assertFieldMissing fetched "link"
      listResp <- getMeetingsList owner
      assertSuccess listResp
      meetingsList <- listResp.json & asList
      assertFieldMissing (head meetingsList) "link"

  -- V17/V18-pinned reads carry no @link@ field.
  legacy <- getMeetingV 18 owner domain meetingId >>= getJSON 200
  assertFieldMissing legacy "link"
  legacyV16 <- getMeetingV 16 owner domain meetingId >>= getJSON 200
  assertFieldMissing legacyV16 "link"

  deleteMeeting owner domain meetingId >>= assertStatus 200
  getMeeting owner domain meetingId >>= assertStatus 404

-- | WPB-28987: in multi-ingress mode a meeting created by a user whose domain
-- has no configured join-link URI carries no @link@ field (the old fallback
-- would have fabricated one). Holds regardless of code-storage mode.
testMeetingLinkMultiIngress :: (HasCallStack) => App ()
testMeetingLinkMultiIngress :: HasCallStack => App ()
testMeetingLinkMultiIngress =
  ServiceOverrides -> (HasCallStack => String -> App ()) -> App ()
forall a.
HasCallStack =>
ServiceOverrides -> (HasCallStack => String -> App a) -> App a
withModifiedBackend
    ( ServiceOverrides
forall a. Default a => a
def
        { galleyCfg = \Value
conf ->
            Value
conf
              Value -> (Value -> App Value) -> App Value
forall a b. a -> (a -> b) -> b
& String -> Value -> Value -> App Value
forall a b.
(HasCallStack, MakesValue a, ToJSON b) =>
String -> b -> a -> App Value
setField String
"settings.conversationCodeURI" Value
Null
              App Value -> (App Value -> App Value) -> App Value
forall a b. a -> (a -> b) -> b
& String -> Value -> App Value -> App Value
forall a b.
(HasCallStack, MakesValue a, ToJSON b) =>
String -> b -> a -> App Value
setField
                String
"settings.multiIngress"
                ([Pair] -> Value
object [String
"red.example.com" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= (String
"https://red.example.com/conversation-join/" :: String)])
        }
    )
    ((HasCallStack => String -> App ()) -> App ())
-> (HasCallStack => String -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \String
domain -> do
      (owner, _tid, _members) <- String -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam String
domain Int
1
      now <- liftIO getCurrentTime
      let newMeeting = String -> UTCTime -> UTCTime -> [String] -> Value
defaultMeetingJson String
"Multi Ingress Meeting" (NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
3600 UTCTime
now) (NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
7200 UTCTime
now) []
      meeting <- postMeetings owner newMeeting >>= getJSON 201
      -- The dynamic backend's domain is not in the multiIngress map.
      assertFieldMissing meeting "link"

-- | A meeting created via the V18 shape (no @type@) is readable via V19 and
-- carries the stored default type @scheduled@.
testMeetingInteropV18ToV19 :: (HasCallStack) => App ()
testMeetingInteropV18ToV19 :: HasCallStack => App ()
testMeetingInteropV18ToV19 = do
  (owner, _tid, _members) <- Domain -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam Domain
OwnDomain Int
1
  now <- liftIO getCurrentTime
  let startTime = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
3600 UTCTime
now
      endTime = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
7200 UTCTime
now
      newMeeting =
        [Pair] -> Value
object
          [ String
"title" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= (String
"Interop V18" :: String),
            String
"start_time" String -> UTCTime -> Pair
forall a. ToJSON a => String -> a -> Pair
.= UTCTime
startTime,
            String
"end_time" String -> UTCTime -> Pair
forall a. ToJSON a => String -> a -> Pair
.= UTCTime
endTime,
            String
"tzid" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= (String
"Europe/Berlin" :: String),
            String
"invited_emails" String -> [String] -> Pair
forall a. ToJSON a => String -> a -> Pair
.= ([] :: [String])
          ]
  meeting <- postMeetingsV 18 owner newMeeting >>= getJSON 201
  (meetingId, domain) <- getMeetingIdAndDomain meeting
  modern <- getMeeting owner domain meetingId >>= getJSON 200
  mtype <- modern %. "type" >>= asString
  mtype `shouldMatch` ("scheduled" :: String)

-- | WPB-28216: refreshing a meeting's join link recreates the join code
-- (rotating the code embedded in the @link@ URL), revokes the meeting
-- conversation's guest link, and enforces creator-only access.
testMeetingLinkRefresh :: (HasCallStack) => App ()
testMeetingLinkRefresh :: HasCallStack => App ()
testMeetingLinkRefresh = do
  (owner, _tid, _members) <- Domain -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam Domain
OwnDomain Int
1
  now <- liftIO getCurrentTime
  let startTime = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
3600 UTCTime
now
      endTime = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
7200 UTCTime
now
      newMeeting = String -> UTCTime -> UTCTime -> [String] -> Value
defaultMeetingJson String
"Refresh Integration" UTCTime
startTime UTCTime
endTime []

  meeting <- postMeetings owner newMeeting >>= getJSON 201
  (meetingId, domain) <- getMeetingIdAndDomain meeting
  titleBefore <- meeting %. "title" >>= asString
  -- The link is absent on deployments without a configured join-link URI
  -- (e.g. the default integration stack); mirror testMeetingLink's guard.
  mLinkBefore <- lookupField meeting "link" >>= maybe (pure Nothing) asStringM

  conv <- meeting %. "conversation"

  -- Plant a guest link on the meeting conversation; refresh must revoke it.
  postConversationCode owner conv Nothing Nothing >>= assertSuccess
  getConversationCode owner conv Nothing >>= assertStatus 200

  refreshed <- postMeetingLinkRefresh owner domain meetingId (object []) >>= getJSON 200
  -- V19 MeetingWithConversation flattens the meeting fields to the top level.
  refreshedTitle <- refreshed %. "title" >>= asString
  refreshedTitle `shouldMatch` titleBefore
  refreshedLink <- lookupField refreshed "link" >>= maybe (pure Nothing) asStringM

  -- The refresh rotates the code carried by the link URL.
  case (mLinkBefore, refreshedLink) of
    (Just String
linkBefore, Just String
linkAfter) -> do
      String
linkAfter String -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldNotMatch` String
linkBefore
      let (String
keyBefore, String
codeBefore) = String -> (String, String)
linkKeyAndCode String
linkBefore
          (String
keyAfter, String
codeAfter) = String -> (String, String)
linkKeyAndCode String
linkAfter
      -- The stale (pre-refresh) link code no longer resolves: the key is
      -- stable across the refresh, the rotated code value is what kills it.
      Value -> String -> String -> String -> Maybe String -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> String -> String -> String -> Maybe String -> App Response
postMeetingJoin Value
owner String
domain String
keyBefore String
codeBefore Maybe String
forall a. Maybe a
Nothing App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> String -> Response -> App ()
Int -> String -> Response -> App ()
assertLabel Int
404 String
"meeting-not-found"
      Value -> String -> String -> String -> Maybe String -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> String -> String -> String -> Maybe String -> App Response
postMeetingJoin Value
owner String
domain String
keyAfter String
codeAfter Maybe String
forall a. Maybe a
Nothing App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
200
    (Maybe String
Nothing, Maybe String
Nothing) -> () -> App ()
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure () -- no join-link URI configured
    (Maybe String, Maybe String)
_ -> String -> App ()
forall a. HasCallStack => String -> App a
assertFailure String
"refresh changed link presence"

  -- The meeting conversation's guest link is revoked.
  getConversationCode owner conv Nothing >>= assertLabel 404 "no-conversation-code"

  -- Only the creator may refresh.
  (otherUser, _, _) <- createTeam OwnDomain 1
  postMeetingLinkRefresh otherUser domain meetingId (object []) >>= assertStatus 404

  -- Refreshing a deleted meeting yields 404.
  deleteMeeting owner domain meetingId >>= assertStatus 200
  postMeetingLinkRefresh owner domain meetingId (object []) >>= assertStatus 404

  -- A too-short password is rejected by the request schema (min length 8).
  meeting2 <- postMeetings owner newMeeting >>= getJSON 201
  (meetingId2, domain2) <- getMeetingIdAndDomain meeting2
  postMeetingLinkRefresh owner domain2 meetingId2 (object ["password" .= ("short7" :: String)]) >>= assertStatus 400

-- | Extract the (key, code) query parameters from a meeting join link URL
-- (@…/meeting-join/?key=\<key\>&code=\<code\>&domain=…@). The URL contains
-- exactly one @?@ and the three known parameters; missing parts yield @\"\"@.
linkKeyAndCode :: String -> (String, String)
linkKeyAndCode :: String -> (String, String)
linkKeyAndCode String
link = (String -> String
lookupParam String
"key=", String -> String
lookupParam String
"code=")
  where
    query :: String
query = Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
1 ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'?') String
link)
    params :: [String]
params = Char -> String -> [String]
forall {a} {t :: * -> *}. (Eq a, Foldable t) => a -> t a -> [[a]]
splitOnChar Char
'&' String
query
    splitOnChar :: a -> t a -> [[a]]
splitOnChar a
sep = (a -> [[a]] -> [[a]]) -> [[a]] -> t a -> [[a]]
forall a b. (a -> b -> b) -> b -> t a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> [[a]] -> [[a]]
step [[]]
      where
        step :: a -> [[a]] -> [[a]]
step a
c acc :: [[a]]
acc@([a]
x : [[a]]
xs)
          | a
c a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
sep = [] [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: [[a]]
acc
          | Bool
otherwise = (a
c a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
x) [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: [[a]]
xs
        step a
_ [] = []
    lookupParam :: String -> String
lookupParam String
p = case (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String
p String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) [String]
params of
      (String
x : [String]
_) -> Int -> String -> String
forall a. Int -> [a] -> [a]
drop (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
p) String
x
      [] -> String
""

-- | WPB-28216: @POST /meeting/{domain}/{key}/{code}/join@ joins a meeting
-- through its join link for any authenticated local user (re-joining is an
-- idempotent no-op) and enforces the optional password.
-- The code value is the rotating capability: stale values (superseded by a
-- refresh) yield 404.
testMeetingJoinByLink :: (HasCallStack) => App ()
testMeetingJoinByLink :: HasCallStack => App ()
testMeetingJoinByLink = do
  (owner, _tid, [bob]) <- Domain -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam Domain
OwnDomain Int
2
  now <- liftIO getCurrentTime
  let startTime = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
3600 UTCTime
now
      endTime = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
7200 UTCTime
now
      newMeeting = String -> UTCTime -> UTCTime -> [String] -> Value
defaultMeetingJson String
"Join Integration" UTCTime
startTime UTCTime
endTime []

  meeting <- postMeetings owner newMeeting >>= getJSON 201
  (meetingId, domain) <- getMeetingIdAndDomain meeting
  mLink <- lookupField meeting "link" >>= maybe (pure Nothing) asStringM

  -- A non-creator can resolve a passwordless link.
  case mLink of
    Maybe String
Nothing -> () -> App ()
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure () -- no join-link URI configured; the link is unusable
    Just String
link -> do
      title <- Value
meeting Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"title" App Value -> (Value -> App String) -> App String
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString
      let (oldKey, oldCode) = linkKeyAndCode link
      joined <- postMeetingJoin bob domain oldKey oldCode Nothing >>= getJSON 200
      joinedTitle <- joined %. "title" >>= asString
      joinedTitle `shouldMatch` title
      -- Password-protect the link via refresh; this rotates the code value.
      refreshed <- postMeetingLinkRefresh owner domain meetingId (object ["password" .= ("supersecret8" :: String)]) >>= getJSON 200
      newLink <- refreshed %. "link" >>= asString
      let (newKey, newCode) = linkKeyAndCode newLink

      -- The stale (pre-refresh) code no longer resolves.
      postMeetingJoin bob domain oldKey oldCode Nothing >>= assertLabel 404 "meeting-not-found"
      postMeetingJoin bob domain newKey newCode Nothing >>= assertLabel 403 "invalid-meeting-password"
      postMeetingJoin bob domain newKey newCode (Just "wrongpass1") >>= assertLabel 403 "invalid-meeting-password"
      ok <- postMeetingJoin bob domain newKey newCode (Just "supersecret8")
      assertStatus 200 ok

      -- Clearing the password makes the link passwordless again.
      clearedLink <- postMeetingLinkRefresh owner domain meetingId (object ["password" .= Null]) >>= getJSON 200 >>= (%. "link") >>= asString
      let (clearedKey, clearedCode) = linkKeyAndCode clearedLink
      postMeetingJoin bob domain clearedKey clearedCode Nothing >>= assertStatus 200

      -- A deleted meeting has no resolvable link.
      deleteMeeting owner domain meetingId >>= assertStatus 200
      postMeetingJoin bob domain clearedKey clearedCode Nothing >>= assertLabel 404 "meeting-not-found"

-- | WPB-28989: @GET /meeting/{domain}/{key}/{code}/code-check@ checks a
-- meeting join link unauthenticated (metadata only) and
-- @POST /meeting/{domain}/{key}/{code}/join@ joins the meeting's
-- conversation. No creator or conversation membership is required;
-- password-protected links require the matching password on both verbs.
testMeetingLinkJoin :: (HasCallStack) => App ()
testMeetingLinkJoin :: HasCallStack => App ()
testMeetingLinkJoin = do
  -- Meeting join codes live in the Postgres code store only. In
  -- cassandra-only mode a fresh meeting has no code (@hasCode == False@), so
  -- its join link deliberately fails closed: assert that instead of the
  -- positive path below.
  codeStorage <- Service -> App Value
readServiceConfig Service
Galley App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"postgresMigration.conversationCodes" App Value -> (Value -> App String) -> App String
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString
  let isCassandraCodeStore = String
codeStorage String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"cassandra"

  (alice, _tid, [bob]) <- createTeam OwnDomain 2
  now <- liftIO getCurrentTime
  let newMeeting = String -> UTCTime -> UTCTime -> [String] -> Value
defaultMeetingJson String
"Link Meeting" (NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
3600 UTCTime
now) (NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
7200 UTCTime
now) []

  meeting <- postMeetings alice newMeeting >>= getJSON 201
  (meetingId, domain) <- getMeetingIdAndDomain meeting

  when isCassandraCodeStore $ do
    -- Fail closed with format-valid but unknown key/code (Key is exactly 20
    -- base64url chars, Value 6-20): nothing resolves.
    let key = Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
20 Char
'A'
        code = Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
12 Char
'A'
    getMeetingCodeCheck bob domain key code Nothing >>= assertLabel 404 "meeting-not-found"
    postMeetingJoin bob domain key code Nothing >>= assertLabel 404 "meeting-not-found"

  unless isCassandraCodeStore $ do
    mLink <- lookupField meeting "link" >>= maybe (pure Nothing) asStringM
    case mLink of
      Maybe String
Nothing -> () -> App ()
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure () -- no join-link URI configured; the link is unusable
      Just String
link -> do
        let (String
key, String
code) = String -> (String, String)
linkKeyAndCode String
link
        title <- Value
meeting Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"title" App Value -> (Value -> App String) -> App String
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString

        -- GET resolves the link read-only for a user who is neither creator
        -- nor member: no membership change.
        -- Unauthenticated metadata preview: title, time, recurrence.
        fetched <- getMeetingCodeCheck bob domain key code Nothing >>= getJSON 200
        fetched %. "title" `shouldMatch` title
        fetched %. "start_time" `shouldMatch` (meeting %. "start_time")
        fetched %. "end_time" `shouldMatch` (meeting %. "end_time")
        fetched %. "tzid" `shouldMatch` (meeting %. "tzid")
        -- no identity leakage: the preview carries no conversation or id
        assertFieldMissing fetched "conversation"
        assertFieldMissing fetched "qualified_id"
        convQid <- meeting %. "conversation" %. "qualified_id"
        convBefore <- getConversation alice convQid >>= getJSON 200
        othersBefore <- convBefore %. "members.others" & asList
        othersBefore `shouldMatchSet` ([] :: [Value])

        -- POST joins the meeting conversation and returns meeting + conversation
        joined <- postMeetingJoin bob domain key code Nothing >>= getJSON 200
        joined %. "qualified_id" %. "id" `shouldMatch` meetingId
        assertConversationMatchesLegacy joined

        -- Bob is now a member of the meeting conversation: his own view shows
        -- himself as member (members.self), and alice's view shows him in others.
        joinedConvQid <- joined %. "conversation" %. "qualified_id"
        convAsBob <- getConversation bob joinedConvQid >>= getJSON 200
        convAsBob %. "members" %. "self" %. "qualified_id" `shouldMatch` objQidObject bob
        convAsAlice <- getConversation alice joinedConvQid >>= getJSON 200
        others <- convAsAlice %. "members.others" & asList
        bobQid <- objQidObject bob
        otherIds <- for others (%. "qualified_id")
        otherIds `shouldMatchSet` [bobQid]

        -- Password matrix: the password gates resolving and joining.
        refreshed <- postMeetingLinkRefresh alice domain meetingId (object ["password" .= ("supersecret8" :: String)]) >>= getJSON 200
        newLink <- refreshed %. "link" >>= asString
        let (newKey, newCode) = linkKeyAndCode newLink
        -- GET without the password is rejected.
        getMeetingCodeCheck bob domain newKey newCode Nothing >>= assertLabel 403 "invalid-meeting-password"
        -- GET with a wrong password is rejected.
        getMeetingCodeCheck bob domain newKey newCode (Just "wrongsecret8") >>= assertLabel 403 "invalid-meeting-password"
        -- GET with the correct password resolves.
        getMeetingCodeCheck bob domain newKey newCode (Just "supersecret8") >>= assertStatus 200
        -- POST without the password is rejected.
        postMeetingJoin bob domain newKey newCode Nothing >>= assertLabel 403 "invalid-meeting-password"
        -- POST with the correct password joins (idempotent for the member).
        postMeetingJoin bob domain newKey newCode (Just "supersecret8") >>= assertStatus 200
        -- The stale (pre-refresh) code value no longer resolves.
        getMeetingCodeCheck bob domain key code Nothing >>= assertLabel 404 "meeting-not-found"

-- | @POST /meetings@ accepts an optional @password@ that
-- password-protects the join link/code at creation time; short passwords are
-- rejected at decode time.
testMeetingCreatePassword :: (HasCallStack) => App ()
testMeetingCreatePassword :: HasCallStack => App ()
testMeetingCreatePassword = do
  (owner, _tid, [bob]) <- Domain -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam Domain
OwnDomain Int
2
  domain <- objDomain owner
  now <- liftIO getCurrentTime
  let newMeeting =
        [Pair] -> Value
object
          [ String
"title" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= (String
"Password Created Meeting" :: String),
            String
"start_time" String -> UTCTime -> Pair
forall a. ToJSON a => String -> a -> Pair
.= NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
3600 UTCTime
now,
            String
"end_time" String -> UTCTime -> Pair
forall a. ToJSON a => String -> a -> Pair
.= NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
7200 UTCTime
now,
            String
"tzid" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= (String
"Europe/Berlin" :: String),
            String
"type" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= (String
"scheduled" :: String),
            String
"invited_emails" String -> [String] -> Pair
forall a. ToJSON a => String -> a -> Pair
.= ([] :: [String]),
            String
"password" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= (String
"supersecret8" :: String)
          ]

  -- A too-short password is rejected by the request schema.
  shortPwMeeting <- setField "password" ("short7" :: String) newMeeting
  postMeetings owner shortPwMeeting >>= assertStatus 400

  meeting <- postMeetings owner newMeeting >>= getJSON 201
  mLink <- lookupField meeting "link" >>= maybe (pure Nothing) asStringM
  case mLink of
    Maybe String
Nothing -> () -> App ()
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure () -- cassandra code store or no join-link URI; link unusable
    Just String
link -> do
      Value
meeting Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"has_password" App Value -> Bool -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` Bool
True
      let (String
key, String
code) = String -> (String, String)
linkKeyAndCode String
link
      -- POST join without / wrong password is rejected; correct password joins.
      Value -> String -> String -> String -> Maybe String -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> String -> String -> String -> Maybe String -> App Response
postMeetingJoin Value
bob String
domain String
key String
code Maybe String
forall a. Maybe a
Nothing App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> String -> Response -> App ()
Int -> String -> Response -> App ()
assertLabel Int
403 String
"invalid-meeting-password"
      Value -> String -> String -> String -> Maybe String -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> String -> String -> String -> Maybe String -> App Response
postMeetingJoin Value
bob String
domain String
key String
code (String -> Maybe String
forall a. a -> Maybe a
Just String
"wrongpass1") App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> String -> Response -> App ()
Int -> String -> Response -> App ()
assertLabel Int
403 String
"invalid-meeting-password"
      Value -> String -> String -> String -> Maybe String -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> String -> String -> String -> Maybe String -> App Response
postMeetingJoin Value
bob String
domain String
key String
code (String -> Maybe String
forall a. a -> Maybe a
Just String
"supersecret8") App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
200
      -- GET code-check enforces the same password.
      Value -> String -> String -> String -> Maybe String -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> String -> String -> String -> Maybe String -> App Response
getMeetingCodeCheck Value
bob String
domain String
key String
code Maybe String
forall a. Maybe a
Nothing App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> String -> Response -> App ()
Int -> String -> Response -> App ()
assertLabel Int
403 String
"invalid-meeting-password"
      Value -> String -> String -> String -> Maybe String -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> String -> String -> String -> Maybe String -> App Response
getMeetingCodeCheck Value
bob String
domain String
key String
code (String -> Maybe String
forall a. a -> Maybe a
Just String
"supersecret8") App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
200

testMeetingLinkJoinNotFound :: (HasCallStack) => App ()
testMeetingLinkJoinNotFound :: HasCallStack => App ()
testMeetingLinkJoinNotFound = do
  (alice, _tid, _members) <- Domain -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam Domain
OwnDomain Int
1
  domain <- objDomain alice
  -- Format-valid but unknown credentials (Key: exactly 20 base64url chars,
  -- Value: 6-20); no code row exists for the key, so both verbs 404.
  let key = Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
20 Char
'A'
      code = Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
12 Char
'A'
  getMeetingCodeCheck alice domain key code Nothing >>= assertLabel 404 "meeting-not-found"
  postMeetingJoin alice domain key code Nothing >>= assertLabel 404 "meeting-not-found"