{-# OPTIONS_GHC -Wno-ambiguous-fields #-}
module Test.Cells where
import API.Galley
import qualified API.GalleyInternal as I
import Control.Concurrent
import Control.Concurrent.Async
import Control.Concurrent.STM
import qualified Control.Exception as E
import Control.Monad.Codensity
import Control.Monad.Reader
import Control.Retry
import qualified Data.Aeson as A
import Data.IORef
import qualified Data.Map as Map
import Network.AMQP
import Network.AMQP.Extended
import Notifications
import SetupHelpers
import System.Timeout
import Testlib.Prelude
testCellsEvent :: (HasCallStack) => App ()
testCellsEvent :: HasCallStack => App ()
testCellsEvent = do
(alice, tid, [bob, chaz, dean, eve]) <- Domain -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam Domain
OwnDomain Int
5
conv <- postConversation alice defProteus {team = Just tid} >>= getJSON 201
q <- watchCellsEventsForTeam tid (convEvents conv)
bobId <- bob %. "qualified_id"
chazId <- chaz %. "qualified_id"
deanId <- dean %. "qualified_id"
eveId <- eve %. "qualified_id"
addMembers alice conv def {role = Just "wire_member", users = [bobId]} >>= assertSuccess
I.setCellsState alice conv "pending" >>= assertSuccess
addMembers alice conv def {role = Just "wire_member", users = [chazId]} >>= assertSuccess
do
event <- getMessage q %. "payload.0"
event %. "type" `shouldMatch` "conversation.member-join"
event %. "conversation" `shouldMatch` (conv %. "qualified_id" & objId)
event %. "qualified_from" `shouldMatch` (alice %. "qualified_id")
users <- event %. "data.users" & asList
assertOne users %. "qualified_id" `shouldMatch` chazId
I.setCellsState alice conv "ready" >>= assertSuccess
addMembers alice conv def {role = Just "wire_member", users = [deanId]} >>= assertSuccess
do
event <- getMessage q %. "payload.0"
event %. "type" `shouldMatch` "conversation.member-join"
event %. "conversation" `shouldMatch` (conv %. "qualified_id" & objId)
event %. "qualified_from" `shouldMatch` (alice %. "qualified_id")
users <- event %. "data.users" & asList
assertOne users %. "qualified_id" `shouldMatch` deanId
I.setCellsState alice conv "disabled" >>= assertSuccess
addMembers alice conv def {role = Just "wire_member", users = [eveId]} >>= assertSuccess
assertNoMessage q
testCellsCreationEvent :: (HasCallStack) => App ()
testCellsCreationEvent :: HasCallStack => App ()
testCellsCreationEvent = do
(alice, tid, _) <- Domain -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam Domain
OwnDomain Int
1
q0 <- watchCellsEventsForTeam tid def
conv <- postConversation alice defProteus {team = Just tid, cells = True} >>= getJSON 201
let q = QueueConsumer
q0 {filter = isNotifConv conv} :: QueueConsumer
event <- getMessage q %. "payload.0"
event %. "type" `shouldMatch` "conversation.create"
event %. "qualified_conversation.id" `shouldMatch` (conv %. "qualified_id.id")
event %. "qualified_from" `shouldMatch` (alice %. "qualified_id")
assertNoMessage q
testCellsDeletionEvent :: (HasCallStack) => App ()
testCellsDeletionEvent :: HasCallStack => App ()
testCellsDeletionEvent = do
(alice, tid, _) <- Domain -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam Domain
OwnDomain Int
1
q0 <- watchCellsEventsForTeam tid def
conv <- postConversation alice defProteus {team = Just tid, cells = True} >>= getJSON 201
void $ deleteTeamConversation tid conv alice >>= assertSuccess
let q = QueueConsumer
q0 {filter = isConvDeleteNotif} :: QueueConsumer
event <- getMessage q %. "payload.0"
event %. "type" `shouldMatch` "conversation.delete"
event %. "conversation" `shouldMatch` (conv %. "qualified_id.id")
event %. "qualified_conversation" `shouldMatch` (conv %. "qualified_id")
event %. "qualified_from" `shouldMatch` (alice %. "qualified_id")
event %. "from" `shouldMatch` (alice %. "qualified_id.id")
event %. "team" `shouldMatch` tid
assertNoMessage q
testCellsCreationEventIsSentOnlyOnce :: (HasCallStack) => App ()
testCellsCreationEventIsSentOnlyOnce :: HasCallStack => App ()
testCellsCreationEventIsSentOnlyOnce = 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
2
q0 <- watchCellsEventsForTeam tid def
conv <- postConversation alice defProteus {team = Just tid, cells = True, qualifiedUsers = members} >>= getJSON 201
let q = QueueConsumer
q0 {filter = isNotifConv conv} :: QueueConsumer
event <- getMessage q %. "payload.0"
event %. "type" `shouldMatch` "conversation.create"
event %. "qualified_conversation.id" `shouldMatch` (conv %. "qualified_id.id")
event %. "qualified_from" `shouldMatch` (alice %. "qualified_id")
assertNoMessage q
testCellsFeatureCheck :: (HasCallStack) => App ()
testCellsFeatureCheck :: HasCallStack => App ()
testCellsFeatureCheck = do
(alice, tid, _) <- Domain -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam Domain
OwnDomain Int
1
I.patchTeamFeatureConfig OwnDomain tid "cells" (object ["status" .= "disabled"]) >>= assertSuccess
conv <- postConversation alice defProteus {team = Just tid} >>= getJSON 201
bindResponse (I.setCellsState alice conv "ready") $ \Response
resp -> do
Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
403
Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"label" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"invalid-op"
testCellsEventOnFeatureToggle :: (HasCallStack) => App ()
testCellsEventOnFeatureToggle :: HasCallStack => App ()
testCellsEventOnFeatureToggle = do
(_, tid, _) <- Domain -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam Domain
OwnDomain Int
1
q <- watchCellsEventsForTeam tid def
I.patchTeamFeatureConfig OwnDomain tid "cells" (object ["status" .= "disabled"]) >>= assertSuccess
getMessage q >>= \Value
event -> do
Value
event Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"payload.0.type" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"feature-config.update"
Value
event Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"payload.0.name" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"cells"
Value
event Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"payload.0.team" App Value -> App String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` (String -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString String
tid)
Value
event Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"payload.0.data.status" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"disabled"
I.patchTeamFeatureConfig OwnDomain tid "cells" (object ["status" .= "enabled"]) >>= assertSuccess
getMessage q >>= \Value
event -> do
Value
event Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"payload.0.type" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"feature-config.update"
Value
event Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"payload.0.name" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"cells"
Value
event Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"payload.0.team" App Value -> App String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` (String -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString String
tid)
Value
event Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"payload.0.data.status" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"enabled"
testCellsTeamConversationCheck :: (HasCallStack) => App ()
testCellsTeamConversationCheck :: HasCallStack => App ()
testCellsTeamConversationCheck = do
alice <- Domain -> CreateUser -> App Value
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> CreateUser -> App Value
randomUser Domain
OwnDomain CreateUser
forall a. Default a => a
def
conv <- postConversation alice defProteus >>= getJSON 201
bindResponse (I.setCellsState alice conv "ready") $ \Response
resp -> do
Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
403
Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"label" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"invalid-op"
testCellsIgnoredEvents :: (HasCallStack) => App ()
testCellsIgnoredEvents :: HasCallStack => App ()
testCellsIgnoredEvents = do
(alice, tid, _) <- Domain -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam Domain
OwnDomain Int
1
conv <- postConversation alice defProteus {team = Just tid} >>= getJSON 201
I.setCellsState alice conv "ready" >>= assertSuccess
q <- watchCellsEventsForTeam tid (convEvents conv)
void $ updateMessageTimer alice conv 1000 >>= getBody 200
assertNoMessage q
connectToCellsQueue :: ServiceMap -> TChan Message -> Codensity App ()
connectToCellsQueue :: ServiceMap -> TChan Message -> Codensity App ()
connectToCellsQueue ServiceMap
sm TChan Message
messages = do
queueName <- App String -> Codensity App String
forall (m :: * -> *) a. Monad m => m a -> Codensity m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (App String -> Codensity App String)
-> App String -> Codensity App String
forall a b. (a -> b) -> a -> b
$ (Env -> String) -> App String
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.cellsEventQueue)
env <- lift ask
let opts = (RabbitMqAdminOpts -> AmqpEndpoint
demoteOpts Env
env.rabbitMQConfig :: AmqpEndpoint) {vHost = sm.rabbitMqVHost}
let createConnection :: IO Connection
createConnection =
RetryPolicyM IO
-> [RetryStatus -> Handler IO Bool]
-> (RetryStatus -> IO Connection)
-> IO Connection
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
RetryPolicyM m
-> [RetryStatus -> Handler m Bool] -> (RetryStatus -> m a) -> m a
recovering
(Int -> RetryPolicy
limitRetries Int
5)
[RetryStatus -> Handler IO Bool]
forall (m :: * -> *). MonadIO m => [RetryStatus -> Handler m Bool]
skipAsyncExceptions
( IO Connection -> RetryStatus -> IO Connection
forall a b. a -> b -> a
const (IO Connection -> RetryStatus -> IO Connection)
-> IO Connection -> RetryStatus -> IO Connection
forall a b. (a -> b) -> a -> b
$ do
connOpts <-
AmqpEndpoint -> Maybe Text -> IO ConnectionOpts
forall (m :: * -> *).
MonadIO m =>
AmqpEndpoint -> Maybe Text -> m ConnectionOpts
mkConnectionOpts AmqpEndpoint
opts Maybe Text
forall k1. Maybe k1
Nothing
liftIO $ openConnection'' connOpts
)
conn <-
hoistCodensity
$ Codensity
$ E.bracket createConnection closeConnection
chan <-
hoistCodensity
$ Codensity
$ E.bracket (openChannel conn) closeChannel
handler <- lift $ appToIOKleisli $ \(Message
m, Envelope
e) -> do
IO () -> App ()
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> App ()) -> IO () -> App ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TChan Message -> Message -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan Message
messages Message
m
IO () -> App ()
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> App ()) -> IO () -> App ()
forall a b. (a -> b) -> a -> b
$ Channel -> LongLongInt -> Bool -> IO ()
ackMsg Channel
chan Envelope
e.envDeliveryTag Bool
False
void
. hoistCodensity
$ Codensity
$ E.bracket
(consumeMsgs chan (fromString queueName) Ack handler)
(cancelConsumer chan)
getNextMessage :: QueueConsumer -> App Value
getNextMessage :: QueueConsumer -> App Value
getNextMessage QueueConsumer
q = do
m <- IO Message -> App Message
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Message -> App Message) -> IO Message -> App Message
forall a b. (a -> b) -> a -> b
$ STM Message -> IO Message
forall a. STM a -> IO a
atomically (STM Message -> IO Message) -> STM Message -> IO Message
forall a b. (a -> b) -> a -> b
$ TChan Message -> STM Message
forall a. TChan a -> STM a
readTChan QueueConsumer
q.chan
v <- either assertFailure pure $ A.eitherDecode m.msgBody
ok <- q.filter v
if ok
then pure v
else getNextMessage q
getMessageMaybe :: QueueConsumer -> App (Maybe Value)
getMessageMaybe :: QueueConsumer -> App (Maybe Value)
getMessageMaybe QueueConsumer
q = do
timeOutSeconds <- (Env -> Int) -> App Int
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.timeOutSeconds)
next <- appToIO (getNextMessage q)
liftIO $ timeout (timeOutSeconds * 1000000) next
getMessage :: QueueConsumer -> App Value
getMessage :: QueueConsumer -> App Value
getMessage QueueConsumer
q = QueueConsumer -> App (Maybe Value)
getMessageMaybe QueueConsumer
q App (Maybe Value) -> (Maybe Value -> 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
>>= String -> Maybe Value -> App Value
forall a. HasCallStack => String -> Maybe a -> App a
assertJust String
"Cells queue timeout"
assertNoMessage :: QueueConsumer -> App ()
assertNoMessage :: QueueConsumer -> App ()
assertNoMessage QueueConsumer
f =
QueueConsumer -> App (Maybe Value)
getMessageMaybe QueueConsumer
f App (Maybe Value) -> (Maybe Value -> 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
>>= \case
Maybe Value
Nothing -> () -> App ()
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Just Value
m -> do
j <- Value -> App String
forall a. MakesValue a => a -> App String
prettyJSON Value
m
assertFailure $ "Expected no message, got:\n" <> j
data QueueConsumer = QueueConsumer
{ QueueConsumer -> TChan Message
chan :: TChan Message,
QueueConsumer -> Value -> App Bool
filter :: Value -> App Bool
}
startQueueWatcher :: ServiceMap -> App QueueWatcher
startQueueWatcher :: ServiceMap -> App QueueWatcher
startQueueWatcher ServiceMap
sm = do
broadcast <- IO (TChan Message) -> App (TChan Message)
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (TChan Message)
forall a. IO (TChan a)
newBroadcastTChanIO
readyVar <- liftIO $ newEmptyMVar
doneVar <- liftIO $ newEmptyMVar
startIO <- appToIO $ lowerCodensity $ do
void $ connectToCellsQueue sm broadcast
liftIO $ putMVar readyVar ()
liftIO $ takeMVar doneVar
void $ liftIO $ async startIO
liftIO $ takeMVar readyVar
pure QueueWatcher {doneVar, broadcast}
ensureWatcher :: String -> App QueueWatcher
ensureWatcher :: String -> App QueueWatcher
ensureWatcher String
domain = do
watchersLock <- (Env -> MVar ()) -> App (MVar ())
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.cellsEventWatchersLock)
watchersRef <- asks (.cellsEventWatchers)
serviceMaps <- asks (.serviceMap)
sm <- assertOne $ Map.lookup domain serviceMaps
start <- appToIO (startQueueWatcher sm)
liftIO
$ E.bracket
(putMVar watchersLock ())
(\()
_ -> MVar () -> IO (Maybe ())
forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar ()
watchersLock)
$ \()
_ -> do
watchers <- IO (Map String QueueWatcher) -> IO (Map String QueueWatcher)
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Map String QueueWatcher) -> IO (Map String QueueWatcher))
-> IO (Map String QueueWatcher) -> IO (Map String QueueWatcher)
forall a b. (a -> b) -> a -> b
$ IORef (Map String QueueWatcher) -> IO (Map String QueueWatcher)
forall a. IORef a -> IO a
readIORef IORef (Map String QueueWatcher)
watchersRef
case Map.lookup domain watchers of
Maybe QueueWatcher
Nothing -> do
watcher <- IO QueueWatcher
start
let watchers' = String
-> QueueWatcher
-> Map String QueueWatcher
-> Map String QueueWatcher
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert String
domain QueueWatcher
watcher Map String QueueWatcher
watchers
writeIORef watchersRef watchers'
pure watcher
Just QueueWatcher
watcher -> QueueWatcher -> IO QueueWatcher
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure QueueWatcher
watcher
data WatchCellsEvents = WatchCellsEvents
{ WatchCellsEvents -> Either Domain String
domain :: Either Domain String,
WatchCellsEvents -> Value -> App Bool
filter :: Value -> App Bool
}
instance Default WatchCellsEvents where
def :: WatchCellsEvents
def =
WatchCellsEvents
{ domain :: Either Domain String
domain = Domain -> Either Domain String
forall a b. a -> Either a b
Left Domain
OwnDomain,
filter :: Value -> App Bool
filter = App Bool -> Value -> App Bool
forall a b. a -> b -> a
const (Bool -> App Bool
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True)
}
convEvents :: (MakesValue conv) => conv -> WatchCellsEvents
convEvents :: forall conv. MakesValue conv => conv -> WatchCellsEvents
convEvents conv
conv = WatchCellsEvents
forall a. Default a => a
def {filter = isNotifConv conv}
watchCellsEvents :: WatchCellsEvents -> App QueueConsumer
watchCellsEvents :: WatchCellsEvents -> App QueueConsumer
watchCellsEvents WatchCellsEvents
opts = do
domain <- (Domain -> App String)
-> (String -> App String) -> Either Domain String -> App String
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (App Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString (App Value -> App String)
-> (Domain -> App Value) -> Domain -> App String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Domain -> App Value
forall a. (MakesValue a, HasCallStack) => a -> App Value
make) String -> App String
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure WatchCellsEvents
opts.domain
watcher <- ensureWatcher domain
chan <- liftIO $ atomically $ dupTChan watcher.broadcast
pure QueueConsumer {filter = opts.filter, chan}
watchCellsEventsForTeam :: String -> WatchCellsEvents -> App QueueConsumer
watchCellsEventsForTeam :: String -> WatchCellsEvents -> App QueueConsumer
watchCellsEventsForTeam String
tid WatchCellsEvents
opts = do
q <- WatchCellsEvents -> App QueueConsumer
watchCellsEvents WatchCellsEvents
opts
let isEventForTeam Value
v = forall a b.
(MakesValue a, MakesValue b) =>
a -> String -> b -> App Bool
fieldEquals @Value Value
v String
"payload.0.team" String
tid
pure $ q {filter = isEventForTeam}