module Test.Events where

import API.Brig
import API.BrigCommon
import API.Common
import API.Galley
import API.Gundeck
import qualified Control.Concurrent.Timeout as Timeout
import Control.Retry
import Data.ByteString.Conversion (toByteString')
import qualified Data.Text as Text
import Data.Timeout
import qualified Network.WebSockets as WS
import Notifications
import SetupHelpers
import Testlib.Prelude hiding (assertNoEvent)
import Testlib.Printing
import UnliftIO hiding (handle)

-- FUTUREWORK: Investigate why these tests are failing without
-- `withModifiedBackend`; No events are received otherwise.
testConsumeEventsOneWebSocket :: (HasCallStack) => App ()
testConsumeEventsOneWebSocket :: HasCallStack => App ()
testConsumeEventsOneWebSocket = do
  ServiceOverrides -> (HasCallStack => String -> App ()) -> App ()
forall a.
HasCallStack =>
ServiceOverrides -> (HasCallStack => String -> App a) -> App a
withModifiedBackend ServiceOverrides
forall a. Default a => a
def \String
domain -> do
    Value
alice <- String -> CreateUser -> App Value
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> CreateUser -> App Value
randomUser String
domain CreateUser
forall a. Default a => a
def

    Response
lastNotifResp <-
      RetryPolicyM App
-> (RetryStatus -> Response -> App Bool)
-> (RetryStatus -> App Response)
-> App Response
forall (m :: * -> *) b.
MonadIO m =>
RetryPolicyM m
-> (RetryStatus -> b -> m Bool) -> (RetryStatus -> m b) -> m b
retrying
        (Int -> RetryPolicyM App
forall (m :: * -> *). Monad m => Int -> RetryPolicyM m
constantDelay Int
10_000 RetryPolicyM App -> RetryPolicyM App -> RetryPolicyM App
forall a. Semigroup a => a -> a -> a
<> Int -> RetryPolicy
limitRetries Int
10)
        (\RetryStatus
_ Response
resp -> Bool -> App Bool
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> App Bool) -> Bool -> App Bool
forall a b. (a -> b) -> a -> b
$ Response
resp.status Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
404)
        (\RetryStatus
_ -> Value -> GetNotification -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> GetNotification -> App Response
getLastNotification Value
alice GetNotification
forall a. Default a => a
def)
    String
lastNotifId <- Response
lastNotifResp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"id" App Value -> (App Value -> App String) -> App String
forall a b. a -> (a -> b) -> b
& App Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString

    Value
client <- Value -> AddClient -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> AddClient -> App Response
addClient Value
alice AddClient
forall a. Default a => a
def {acapabilities = Just ["consumable-notifications"]} 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
201
    String
clientId <- Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
objId Value
client

    Value -> String -> (TChan Value -> TChan Value -> App ()) -> App ()
forall uid a.
(HasCallStack, MakesValue uid) =>
uid -> String -> (TChan Value -> TChan Value -> App a) -> App a
withEventsWebSocket Value
alice String
clientId ((TChan Value -> TChan Value -> App ()) -> App ())
-> (TChan Value -> TChan Value -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \TChan Value
eventsChan TChan Value
ackChan -> do
      Value
deliveryTag <- TChan Value -> (HasCallStack => Value -> App Value) -> App Value
forall a.
HasCallStack =>
TChan Value -> (HasCallStack => Value -> App a) -> App a
assertEvent TChan Value
eventsChan ((HasCallStack => Value -> App Value) -> App Value)
-> (HasCallStack => Value -> App Value) -> App Value
forall a b. (a -> b) -> a -> b
$ \Value
e -> do
        Value
e Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"type" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"event"
        Value
e Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"data.event.payload.0.type" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"user.client-add"
        Value
e Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"data.event.payload.0.client.id" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
clientId
        Value
e Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"data.delivery_tag"
      HasCallStack => TChan Value -> App ()
TChan Value -> App ()
assertNoEvent TChan Value
eventsChan

      HasCallStack => TChan Value -> Value -> Bool -> App ()
TChan Value -> Value -> Bool -> App ()
sendAck TChan Value
ackChan Value
deliveryTag Bool
False
      HasCallStack => TChan Value -> App ()
TChan Value -> App ()
assertNoEvent TChan Value
eventsChan

      String
handle <- App String
randomHandle
      Value -> String -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> String -> App Response
putHandle Value
alice String
handle 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

      TChan Value -> (HasCallStack => Value -> App ()) -> App ()
forall a.
HasCallStack =>
TChan Value -> (HasCallStack => Value -> App a) -> App a
assertEvent TChan Value
eventsChan ((HasCallStack => Value -> App ()) -> App ())
-> (HasCallStack => Value -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \Value
e -> do
        Value
e Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"type" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"event"
        Value
e Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"data.event.payload.0.type" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"user.update"
        Value
e Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"data.event.payload.0.user.handle" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
handle

    -- No new notifications should be stored in Cassandra as the user doesn't have
    -- any legacy clients
    Value -> GetNotifications -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> GetNotifications -> App Response
getNotifications Value
alice GetNotifications
forall a. Default a => a
def {since = Just lastNotifId} App Response -> (Response -> App ()) -> App ()
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
      App Value -> App ()
forall a. (MakesValue a, HasCallStack) => a -> App ()
shouldBeEmpty (App Value -> App ()) -> App Value -> App ()
forall a b. (a -> b) -> a -> b
$ Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"notifications"

testConsumeEventsForDifferentUsers :: (HasCallStack) => App ()
testConsumeEventsForDifferentUsers :: HasCallStack => App ()
testConsumeEventsForDifferentUsers = do
  ServiceOverrides -> (HasCallStack => String -> App ()) -> App ()
forall a.
HasCallStack =>
ServiceOverrides -> (HasCallStack => String -> App a) -> App a
withModifiedBackend ServiceOverrides
forall a. Default a => a
def ((HasCallStack => String -> App ()) -> App ())
-> (HasCallStack => String -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \String
domain -> do
    Value
alice <- String -> CreateUser -> App Value
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> CreateUser -> App Value
randomUser String
domain CreateUser
forall a. Default a => a
def
    Value
bob <- String -> CreateUser -> App Value
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> CreateUser -> App Value
randomUser String
domain CreateUser
forall a. Default a => a
def

    Value
aliceClient <- Value -> AddClient -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> AddClient -> App Response
addClient Value
alice AddClient
forall a. Default a => a
def {acapabilities = Just ["consumable-notifications"]} 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
201
    String
aliceClientId <- Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
objId Value
aliceClient

    Value
bobClient <- Value -> AddClient -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> AddClient -> App Response
addClient Value
bob AddClient
forall a. Default a => a
def {acapabilities = Just ["consumable-notifications"]} 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
201
    String
bobClientId <- Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
objId Value
bobClient

    [(Value, String)]
-> ([(TChan Value, TChan Value)] -> App ()) -> App ()
forall uid a.
(HasCallStack, MakesValue uid) =>
[(uid, String)] -> ([(TChan Value, TChan Value)] -> App a) -> App a
withEventsWebSockets [(Value
alice, String
aliceClientId), (Value
bob, String
bobClientId)] (([(TChan Value, TChan Value)] -> App ()) -> App ())
-> ([(TChan Value, TChan Value)] -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \[(TChan Value
aliceEventsChan, TChan Value
aliceAckChan), (TChan Value
bobEventsChan, TChan Value
bobAckChan)] -> do
      HasCallStack => String -> TChan Value -> TChan Value -> App ()
String -> TChan Value -> TChan Value -> App ()
assertClientAdd String
aliceClientId TChan Value
aliceEventsChan TChan Value
aliceAckChan
      HasCallStack => String -> TChan Value -> TChan Value -> App ()
String -> TChan Value -> TChan Value -> App ()
assertClientAdd String
bobClientId TChan Value
bobEventsChan TChan Value
bobAckChan
  where
    assertClientAdd :: (HasCallStack) => String -> TChan Value -> TChan Value -> App ()
    assertClientAdd :: HasCallStack => String -> TChan Value -> TChan Value -> App ()
assertClientAdd String
clientId TChan Value
eventsChan TChan Value
ackChan = do
      Value
deliveryTag <- TChan Value -> (HasCallStack => Value -> App Value) -> App Value
forall a.
HasCallStack =>
TChan Value -> (HasCallStack => Value -> App a) -> App a
assertEvent TChan Value
eventsChan ((HasCallStack => Value -> App Value) -> App Value)
-> (HasCallStack => Value -> App Value) -> App Value
forall a b. (a -> b) -> a -> b
$ \Value
e -> do
        Value
e Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"data.event.payload.0.type" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"user.client-add"
        Value
e Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"data.event.payload.0.client.id" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
clientId
        Value
e Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"data.delivery_tag"
      HasCallStack => TChan Value -> App ()
TChan Value -> App ()
assertNoEvent TChan Value
eventsChan
      HasCallStack => TChan Value -> Value -> Bool -> App ()
TChan Value -> Value -> Bool -> App ()
sendAck TChan Value
ackChan Value
deliveryTag Bool
False

testConsumeEventsWhileHavingLegacyClients :: (HasCallStack) => App ()
testConsumeEventsWhileHavingLegacyClients :: HasCallStack => App ()
testConsumeEventsWhileHavingLegacyClients = do
  ServiceOverrides -> (HasCallStack => String -> App ()) -> App ()
forall a.
HasCallStack =>
ServiceOverrides -> (HasCallStack => String -> App a) -> App a
withModifiedBackend ServiceOverrides
forall a. Default a => a
def ((HasCallStack => String -> App ()) -> App ())
-> (HasCallStack => String -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \String
domain -> do
    Value
alice <- String -> CreateUser -> App Value
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> CreateUser -> App Value
randomUser String
domain CreateUser
forall a. Default a => a
def

    -- Even if alice has no clients, the notifications should still be persisted
    -- in Cassandra. This choice is kinda arbitrary as these notifications
    -- probably don't mean much, however, it ensures backwards compatibility.
    String
lastNotifId <-
      Value -> Maybe Value -> (Value -> App Bool) -> App Value
forall user lastNotifId.
(HasCallStack, MakesValue user, MakesValue lastNotifId) =>
user -> Maybe lastNotifId -> (Value -> App Bool) -> App Value
awaitNotification Value
alice Maybe Value
noValue (App Bool -> Value -> App Bool
forall a b. a -> b -> a
const (App Bool -> Value -> App Bool) -> App Bool -> Value -> App Bool
forall a b. (a -> b) -> a -> b
$ Bool -> App Bool
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True) 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
notif -> do
        Value
notif 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
"user.activate"
        -- There is only one notification (at the time of writing), so we assume
        -- it to be the last one.
        Value
notif Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"id" App Value -> (App Value -> App String) -> App String
forall a b. a -> (a -> b) -> b
& App Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString

    Value
oldClient <- Value -> AddClient -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> AddClient -> App Response
addClient Value
alice AddClient
forall a. Default a => a
def {acapabilities = Just []} 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
201

    (Value, String, App Value) -> (WebSocket -> App ()) -> App ()
forall w a.
(HasCallStack, ToWSConnect w) =>
w -> (WebSocket -> App a) -> App a
withWebSocket (Value
alice, String
"anything-but-conn", Value
oldClient Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"id") ((WebSocket -> App ()) -> App ())
-> (WebSocket -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \WebSocket
oldWS -> do
      Value
newClient <- Value -> AddClient -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> AddClient -> App Response
addClient Value
alice AddClient
forall a. Default a => a
def {acapabilities = Just ["consumable-notifications"]} 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
201
      String
newClientId <- Value
newClient Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"id" App Value -> (App Value -> App String) -> App String
forall a b. a -> (a -> b) -> b
& App Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString

      Value
oldNotif <- HasCallStack => (Value -> App Bool) -> WebSocket -> App Value
(Value -> App Bool) -> WebSocket -> App Value
awaitMatch Value -> App Bool
forall a. MakesValue a => a -> App Bool
isUserClientAddNotif WebSocket
oldWS
      Value
oldNotif Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"payload.0.client.id" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
newClientId

      Value -> String -> (TChan Value -> TChan Value -> App ()) -> App ()
forall uid a.
(HasCallStack, MakesValue uid) =>
uid -> String -> (TChan Value -> TChan Value -> App a) -> App a
withEventsWebSocket Value
alice String
newClientId ((TChan Value -> TChan Value -> App ()) -> App ())
-> (TChan Value -> TChan Value -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \TChan Value
eventsChan TChan Value
_ ->
        TChan Value -> (HasCallStack => Value -> App ()) -> App ()
forall a.
HasCallStack =>
TChan Value -> (HasCallStack => Value -> App a) -> App a
assertEvent TChan Value
eventsChan ((HasCallStack => Value -> App ()) -> App ())
-> (HasCallStack => Value -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \Value
e -> do
          Value
e Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"data.event.payload.0.type" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"user.client-add"
          Value
e Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"data.event.payload.0.client.id" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
newClientId

    -- All notifs are also in Cassandra because of the legacy client
    Value -> GetNotifications -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> GetNotifications -> App Response
getNotifications Value
alice GetNotifications
forall a. Default a => a
def {since = Just lastNotifId} App Response -> (Response -> App ()) -> App ()
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
      Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"notifications.0.payload.0.type" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"user.client-add"
      Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"notifications.1.payload.0.type" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"user.client-add"

testConsumeEventsAcks :: (HasCallStack) => App ()
testConsumeEventsAcks :: HasCallStack => App ()
testConsumeEventsAcks = do
  ServiceOverrides -> (HasCallStack => String -> App ()) -> App ()
forall a.
HasCallStack =>
ServiceOverrides -> (HasCallStack => String -> App a) -> App a
withModifiedBackend ServiceOverrides
forall a. Default a => a
def ((HasCallStack => String -> App ()) -> App ())
-> (HasCallStack => String -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \String
domain -> do
    Value
alice <- String -> CreateUser -> App Value
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> CreateUser -> App Value
randomUser String
domain CreateUser
forall a. Default a => a
def
    Value
client <- Value -> AddClient -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> AddClient -> App Response
addClient Value
alice AddClient
forall a. Default a => a
def {acapabilities = Just ["consumable-notifications"]} 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
201
    String
clientId <- Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
objId Value
client

    Value -> String -> (TChan Value -> TChan Value -> App ()) -> App ()
forall uid a.
(HasCallStack, MakesValue uid) =>
uid -> String -> (TChan Value -> TChan Value -> App a) -> App a
withEventsWebSocket Value
alice String
clientId ((TChan Value -> TChan Value -> App ()) -> App ())
-> (TChan Value -> TChan Value -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \TChan Value
eventsChan TChan Value
_ackChan -> do
      TChan Value -> (HasCallStack => Value -> App ()) -> App ()
forall a.
HasCallStack =>
TChan Value -> (HasCallStack => Value -> App a) -> App a
assertEvent TChan Value
eventsChan ((HasCallStack => Value -> App ()) -> App ())
-> (HasCallStack => Value -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \Value
e -> do
        Value
e Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"data.event.payload.0.type" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"user.client-add"
        Value
e Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"data.event.payload.0.client.id" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
clientId

    -- without ack, we receive the same event again
    Value -> String -> (TChan Value -> TChan Value -> App ()) -> App ()
forall uid a.
(HasCallStack, MakesValue uid) =>
uid -> String -> (TChan Value -> TChan Value -> App a) -> App a
withEventsWebSocket Value
alice String
clientId ((TChan Value -> TChan Value -> App ()) -> App ())
-> (TChan Value -> TChan Value -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \TChan Value
eventsChan TChan Value
ackChan -> do
      Value
deliveryTag <- TChan Value -> (HasCallStack => Value -> App Value) -> App Value
forall a.
HasCallStack =>
TChan Value -> (HasCallStack => Value -> App a) -> App a
assertEvent TChan Value
eventsChan ((HasCallStack => Value -> App Value) -> App Value)
-> (HasCallStack => Value -> App Value) -> App Value
forall a b. (a -> b) -> a -> b
$ \Value
e -> do
        Value
e Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"data.event.payload.0.type" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"user.client-add"
        Value
e Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"data.event.payload.0.client.id" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
clientId
        Value
e Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"data.delivery_tag"
      HasCallStack => TChan Value -> Value -> Bool -> App ()
TChan Value -> Value -> Bool -> App ()
sendAck TChan Value
ackChan Value
deliveryTag Bool
False

    Value -> String -> (TChan Value -> TChan Value -> App ()) -> App ()
forall uid a.
(HasCallStack, MakesValue uid) =>
uid -> String -> (TChan Value -> TChan Value -> App a) -> App a
withEventsWebSocket Value
alice String
clientId ((TChan Value -> TChan Value -> App ()) -> App ())
-> (TChan Value -> TChan Value -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \TChan Value
eventsChan TChan Value
_ -> do
      HasCallStack => TChan Value -> App ()
TChan Value -> App ()
assertNoEvent TChan Value
eventsChan

testConsumeEventsMultipleAcks :: (HasCallStack) => App ()
testConsumeEventsMultipleAcks :: HasCallStack => App ()
testConsumeEventsMultipleAcks = do
  ServiceOverrides -> (HasCallStack => String -> App ()) -> App ()
forall a.
HasCallStack =>
ServiceOverrides -> (HasCallStack => String -> App a) -> App a
withModifiedBackend ServiceOverrides
forall a. Default a => a
def ((HasCallStack => String -> App ()) -> App ())
-> (HasCallStack => String -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \String
domain -> do
    Value
alice <- String -> CreateUser -> App Value
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> CreateUser -> App Value
randomUser String
domain CreateUser
forall a. Default a => a
def
    Value
client <- Value -> AddClient -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> AddClient -> App Response
addClient Value
alice AddClient
forall a. Default a => a
def {acapabilities = Just ["consumable-notifications"]} 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
201
    String
clientId <- Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
objId Value
client

    String
handle <- App String
randomHandle
    Value -> String -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> String -> App Response
putHandle Value
alice String
handle 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

    Value -> String -> (TChan Value -> TChan Value -> App ()) -> App ()
forall uid a.
(HasCallStack, MakesValue uid) =>
uid -> String -> (TChan Value -> TChan Value -> App a) -> App a
withEventsWebSocket Value
alice String
clientId ((TChan Value -> TChan Value -> App ()) -> App ())
-> (TChan Value -> TChan Value -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \TChan Value
eventsChan TChan Value
ackChan -> do
      TChan Value -> (HasCallStack => Value -> App ()) -> App ()
forall a.
HasCallStack =>
TChan Value -> (HasCallStack => Value -> App a) -> App a
assertEvent TChan Value
eventsChan ((HasCallStack => Value -> App ()) -> App ())
-> (HasCallStack => Value -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \Value
e -> do
        Value
e Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"data.event.payload.0.type" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"user.client-add"
        Value
e Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"data.event.payload.0.client.id" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
clientId

      Value
deliveryTag <- TChan Value -> (HasCallStack => Value -> App Value) -> App Value
forall a.
HasCallStack =>
TChan Value -> (HasCallStack => Value -> App a) -> App a
assertEvent TChan Value
eventsChan ((HasCallStack => Value -> App Value) -> App Value)
-> (HasCallStack => Value -> App Value) -> App Value
forall a b. (a -> b) -> a -> b
$ \Value
e -> do
        Value
e Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"data.event.payload.0.type" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"user.update"
        Value
e Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"data.event.payload.0.user.handle" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
handle
        Value
e Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"data.delivery_tag"

      HasCallStack => TChan Value -> Value -> Bool -> App ()
TChan Value -> Value -> Bool -> App ()
sendAck TChan Value
ackChan Value
deliveryTag Bool
True

    Value -> String -> (TChan Value -> TChan Value -> App ()) -> App ()
forall uid a.
(HasCallStack, MakesValue uid) =>
uid -> String -> (TChan Value -> TChan Value -> App a) -> App a
withEventsWebSocket Value
alice String
clientId ((TChan Value -> TChan Value -> App ()) -> App ())
-> (TChan Value -> TChan Value -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \TChan Value
eventsChan TChan Value
_ -> do
      HasCallStack => TChan Value -> App ()
TChan Value -> App ()
assertNoEvent TChan Value
eventsChan

testConsumeEventsAckNewEventWithoutAckingOldOne :: (HasCallStack) => App ()
testConsumeEventsAckNewEventWithoutAckingOldOne :: HasCallStack => App ()
testConsumeEventsAckNewEventWithoutAckingOldOne = do
  ServiceOverrides -> (HasCallStack => String -> App ()) -> App ()
forall a.
HasCallStack =>
ServiceOverrides -> (HasCallStack => String -> App a) -> App a
withModifiedBackend ServiceOverrides
forall a. Default a => a
def ((HasCallStack => String -> App ()) -> App ())
-> (HasCallStack => String -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \String
domain -> do
    Value
alice <- String -> CreateUser -> App Value
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> CreateUser -> App Value
randomUser String
domain CreateUser
forall a. Default a => a
def
    Value
client <- Value -> AddClient -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> AddClient -> App Response
addClient Value
alice AddClient
forall a. Default a => a
def {acapabilities = Just ["consumable-notifications"]} 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
201
    String
clientId <- Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
objId Value
client

    String
handle <- App String
randomHandle
    Value -> String -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> String -> App Response
putHandle Value
alice String
handle 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

    Value -> String -> (TChan Value -> TChan Value -> App ()) -> App ()
forall uid a.
(HasCallStack, MakesValue uid) =>
uid -> String -> (TChan Value -> TChan Value -> App a) -> App a
withEventsWebSocket Value
alice String
clientId ((TChan Value -> TChan Value -> App ()) -> App ())
-> (TChan Value -> TChan Value -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \TChan Value
eventsChan TChan Value
ackChan -> do
      TChan Value -> (HasCallStack => Value -> App ()) -> App ()
forall a.
HasCallStack =>
TChan Value -> (HasCallStack => Value -> App a) -> App a
assertEvent TChan Value
eventsChan ((HasCallStack => Value -> App ()) -> App ())
-> (HasCallStack => Value -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \Value
e -> do
        Value
e Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"data.event.payload.0.type" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"user.client-add"
        Value
e Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"data.event.payload.0.client.id" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
clientId

      Value
deliveryTagHandleAdd <- TChan Value -> (HasCallStack => Value -> App Value) -> App Value
forall a.
HasCallStack =>
TChan Value -> (HasCallStack => Value -> App a) -> App a
assertEvent TChan Value
eventsChan ((HasCallStack => Value -> App Value) -> App Value)
-> (HasCallStack => Value -> App Value) -> App Value
forall a b. (a -> b) -> a -> b
$ \Value
e -> do
        Value
e Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"data.event.payload.0.type" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"user.update"
        Value
e Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"data.event.payload.0.user.handle" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
handle
        Value
e Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"data.delivery_tag"

      -- Only ack the handle add delivery tag
      HasCallStack => TChan Value -> Value -> Bool -> App ()
TChan Value -> Value -> Bool -> App ()
sendAck TChan Value
ackChan Value
deliveryTagHandleAdd Bool
False

    -- Expect client-add event to be delivered again.
    Value -> String -> (TChan Value -> TChan Value -> App ()) -> App ()
forall uid a.
(HasCallStack, MakesValue uid) =>
uid -> String -> (TChan Value -> TChan Value -> App a) -> App a
withEventsWebSocket Value
alice String
clientId ((TChan Value -> TChan Value -> App ()) -> App ())
-> (TChan Value -> TChan Value -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \TChan Value
eventsChan TChan Value
ackChan -> do
      Value
deliveryTagClientAdd <- TChan Value -> (HasCallStack => Value -> App Value) -> App Value
forall a.
HasCallStack =>
TChan Value -> (HasCallStack => Value -> App a) -> App a
assertEvent TChan Value
eventsChan ((HasCallStack => Value -> App Value) -> App Value)
-> (HasCallStack => Value -> App Value) -> App Value
forall a b. (a -> b) -> a -> b
$ \Value
e -> do
        Value
e Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"data.event.payload.0.type" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"user.client-add"
        Value
e Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"data.event.payload.0.client.id" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
clientId
        Value
e Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"data.delivery_tag"

      HasCallStack => TChan Value -> Value -> Bool -> App ()
TChan Value -> Value -> Bool -> App ()
sendAck TChan Value
ackChan Value
deliveryTagClientAdd Bool
False

    Value -> String -> (TChan Value -> TChan Value -> App ()) -> App ()
forall uid a.
(HasCallStack, MakesValue uid) =>
uid -> String -> (TChan Value -> TChan Value -> App a) -> App a
withEventsWebSocket Value
alice String
clientId ((TChan Value -> TChan Value -> App ()) -> App ())
-> (TChan Value -> TChan Value -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \TChan Value
eventsChan TChan Value
_ -> do
      HasCallStack => TChan Value -> App ()
TChan Value -> App ()
assertNoEvent TChan Value
eventsChan

testEventsDeadLettered :: (HasCallStack) => App ()
testEventsDeadLettered :: HasCallStack => App ()
testEventsDeadLettered = do
  let notifTTL :: Timeout
notifTTL = Word64
1 Word64 -> TimeoutUnit -> Timeout
# TimeoutUnit
Second
  ServiceOverrides -> (HasCallStack => String -> App ()) -> App ()
forall a.
HasCallStack =>
ServiceOverrides -> (HasCallStack => String -> App a) -> App a
withModifiedBackend (ServiceOverrides
forall a. Default a => a
def {gundeckCfg = setField "settings.notificationTTL" (notifTTL #> Second)}) ((HasCallStack => String -> App ()) -> App ())
-> (HasCallStack => String -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \String
domain -> do
    Value
alice <- String -> CreateUser -> App Value
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> CreateUser -> App Value
randomUser String
domain CreateUser
forall a. Default a => a
def

    -- This generates an event
    Value
client <- Value -> AddClient -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> AddClient -> App Response
addClient Value
alice AddClient
forall a. Default a => a
def {acapabilities = Just ["consumable-notifications"]} 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
201
    String
clientId <- Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
objId Value
client

    -- We expire the add client event by waiting it out
    Timeout -> App ()
forall (μ :: * -> *). MonadBase IO μ => Timeout -> μ ()
Timeout.threadDelay (Timeout
notifTTL Timeout -> Timeout -> Timeout
forall a. Num a => a -> a -> a
+ Word64
500 Word64 -> TimeoutUnit -> Timeout
# TimeoutUnit
MilliSecond)

    -- Generate a second event
    String
handle1 <- App String
randomHandle
    Value -> String -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> String -> App Response
putHandle Value
alice String
handle1 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

    Value -> String -> (TChan Value -> TChan Value -> App ()) -> App ()
forall uid a.
(HasCallStack, MakesValue uid) =>
uid -> String -> (TChan Value -> TChan Value -> App a) -> App a
withEventsWebSocket Value
alice String
clientId ((TChan Value -> TChan Value -> App ()) -> App ())
-> (TChan Value -> TChan Value -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \TChan Value
eventsChan TChan Value
ackChan -> do
      TChan Value -> (HasCallStack => Value -> App ()) -> App ()
forall a.
HasCallStack =>
TChan Value -> (HasCallStack => Value -> App a) -> App a
assertEvent TChan Value
eventsChan ((HasCallStack => Value -> App ()) -> App ())
-> (HasCallStack => Value -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \Value
e -> do
        Value
e Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"type" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"notifications.missed"

      -- Until we ack the full sync, we can't get new events
      HasCallStack => TChan Value -> App ()
TChan Value -> App ()
ackFullSync TChan Value
ackChan

      -- withEventsWebSocket alice clientId $ \eventsChan ackChan -> do
      -- Now we can see the next event
      TChan Value -> (HasCallStack => Value -> App ()) -> App ()
forall a.
HasCallStack =>
TChan Value -> (HasCallStack => Value -> App a) -> App a
assertEvent TChan Value
eventsChan ((HasCallStack => Value -> App ()) -> App ())
-> (HasCallStack => Value -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \Value
e -> do
        Value
e Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"data.event.payload.0.type" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"user.update"
        Value
e Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"data.event.payload.0.user.handle" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
handle1
        HasCallStack => TChan Value -> Value -> App ()
TChan Value -> Value -> App ()
ackEvent TChan Value
ackChan Value
e

      -- We've consumed the whole queue.
      HasCallStack => TChan Value -> App ()
TChan Value -> App ()
assertNoEvent TChan Value
eventsChan

testTransientEventsDoNotTriggerDeadLetters :: (HasCallStack) => App ()
testTransientEventsDoNotTriggerDeadLetters :: HasCallStack => App ()
testTransientEventsDoNotTriggerDeadLetters = do
  let notifTTL :: Timeout
notifTTL = Word64
1 Word64 -> TimeoutUnit -> Timeout
# TimeoutUnit
Second
  ServiceOverrides -> (HasCallStack => String -> App ()) -> App ()
forall a.
HasCallStack =>
ServiceOverrides -> (HasCallStack => String -> App a) -> App a
withModifiedBackend (ServiceOverrides
forall a. Default a => a
def {gundeckCfg = setField "settings.notificationTTL" (notifTTL #> Second)}) ((HasCallStack => String -> App ()) -> App ())
-> (HasCallStack => String -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \String
domain -> do
    Value
alice <- String -> CreateUser -> App Value
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> CreateUser -> App Value
randomUser String
domain CreateUser
forall a. Default a => a
def
    -- Creates a non-transient event
    Value
client <- Value -> AddClient -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> AddClient -> App Response
addClient Value
alice AddClient
forall a. Default a => a
def {acapabilities = Just ["consumable-notifications"]} 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
201
    String
clientId <- Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
objId Value
client

    -- consume it
    Value -> String -> (TChan Value -> TChan Value -> App ()) -> App ()
forall uid a.
(HasCallStack, MakesValue uid) =>
uid -> String -> (TChan Value -> TChan Value -> App a) -> App a
withEventsWebSocket Value
alice String
clientId ((TChan Value -> TChan Value -> App ()) -> App ())
-> (TChan Value -> TChan Value -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \TChan Value
eventsChan TChan Value
ackChan -> do
      TChan Value -> (HasCallStack => Value -> App ()) -> App ()
forall a.
HasCallStack =>
TChan Value -> (HasCallStack => Value -> App a) -> App a
assertEvent TChan Value
eventsChan ((HasCallStack => Value -> App ()) -> App ())
-> (HasCallStack => Value -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \Value
e -> do
        Value
e Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"data.event.payload.0.type" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"user.client-add"
        Value
e Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"type" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"event"
        Value
e Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"data.event.payload.0.type" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"user.client-add"
        Value
e Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"data.event.payload.0.client.id" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
clientId
        Value
deliveryTag <- Value
e Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"data.delivery_tag"
        HasCallStack => TChan Value -> Value -> Bool -> App ()
TChan Value -> Value -> Bool -> App ()
sendAck TChan Value
ackChan Value
deliveryTag Bool
False

    -- Self conv ID is same as user's ID, we'll use this to send typing
    -- indicators, so we don't have to create another conv.
    Value
selfConvId <- Value -> App Value
forall a. (HasCallStack, MakesValue a) => a -> App Value
objQidObject Value
alice
    -- Typing status is transient, currently no one is listening.
    Value -> Value -> String -> App Response
forall user conv.
(HasCallStack, MakesValue user, MakesValue conv) =>
user -> conv -> String -> App Response
sendTypingStatus Value
alice Value
selfConvId String
"started" 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

    Value -> String -> (TChan Value -> TChan Value -> App ()) -> App ()
forall uid a.
(HasCallStack, MakesValue uid) =>
uid -> String -> (TChan Value -> TChan Value -> App a) -> App a
withEventsWebSocket Value
alice String
clientId ((TChan Value -> TChan Value -> App ()) -> App ())
-> (TChan Value -> TChan Value -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \TChan Value
eventsChan TChan Value
_ackChan -> do
      HasCallStack => TChan Value -> App ()
TChan Value -> App ()
assertNoEvent TChan Value
eventsChan

testTransientEvents :: (HasCallStack) => App ()
testTransientEvents :: HasCallStack => App ()
testTransientEvents = do
  ServiceOverrides -> (HasCallStack => String -> App ()) -> App ()
forall a.
HasCallStack =>
ServiceOverrides -> (HasCallStack => String -> App a) -> App a
withModifiedBackend ServiceOverrides
forall a. Default a => a
def ((HasCallStack => String -> App ()) -> App ())
-> (HasCallStack => String -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \String
domain -> do
    Value
alice <- String -> CreateUser -> App Value
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> CreateUser -> App Value
randomUser String
domain CreateUser
forall a. Default a => a
def
    Value
client <- Value -> AddClient -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> AddClient -> App Response
addClient Value
alice AddClient
forall a. Default a => a
def {acapabilities = Just ["consumable-notifications"]} 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
201
    String
clientId <- Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
objId Value
client

    -- Self conv ID is same as user's ID, we'll use this to send typing
    -- indicators, so we don't have to create another conv.
    Value
selfConvId <- Value -> App Value
forall a. (HasCallStack, MakesValue a) => a -> App Value
objQidObject Value
alice

    Value -> String -> (TChan Value -> TChan Value -> App ()) -> App ()
forall uid a.
(HasCallStack, MakesValue uid) =>
uid -> String -> (TChan Value -> TChan Value -> App a) -> App a
withEventsWebSocket Value
alice String
clientId ((TChan Value -> TChan Value -> App ()) -> App ())
-> (TChan Value -> TChan Value -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \TChan Value
eventsChan TChan Value
ackChan -> do
      TChan Value -> TChan Value -> App ()
consumeAllEvents TChan Value
eventsChan TChan Value
ackChan
      Value -> Value -> String -> App Response
forall user conv.
(HasCallStack, MakesValue user, MakesValue conv) =>
user -> conv -> String -> App Response
sendTypingStatus Value
alice Value
selfConvId String
"started" 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
      TChan Value -> (HasCallStack => Value -> App ()) -> App ()
forall a.
HasCallStack =>
TChan Value -> (HasCallStack => Value -> App a) -> App a
assertEvent TChan Value
eventsChan ((HasCallStack => Value -> App ()) -> App ())
-> (HasCallStack => Value -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \Value
e -> do
        Value
e Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"data.event.payload.0.type" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"conversation.typing"
        Value
e Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"data.event.payload.0.qualified_conversation" App Value -> Value -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` Value
selfConvId
        Value
deliveryTag <- Value
e Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"data.delivery_tag"
        HasCallStack => TChan Value -> Value -> Bool -> App ()
TChan Value -> Value -> Bool -> App ()
sendAck TChan Value
ackChan Value
deliveryTag Bool
False

    String
handle1 <- App String
randomHandle
    Value -> String -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> String -> App Response
putHandle Value
alice String
handle1 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

    Value -> Value -> String -> App Response
forall user conv.
(HasCallStack, MakesValue user, MakesValue conv) =>
user -> conv -> String -> App Response
sendTypingStatus Value
alice Value
selfConvId String
"stopped" 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

    String
handle2 <- App String
randomHandle
    Value -> String -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> String -> App Response
putHandle Value
alice String
handle2 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

    -- We shouldn't see the stopped typing status because we were not connected to
    -- the websocket when it was sent. The other events should still show up in
    -- order.
    Value -> String -> (TChan Value -> TChan Value -> App ()) -> App ()
forall uid a.
(HasCallStack, MakesValue uid) =>
uid -> String -> (TChan Value -> TChan Value -> App a) -> App a
withEventsWebSocket Value
alice String
clientId ((TChan Value -> TChan Value -> App ()) -> App ())
-> (TChan Value -> TChan Value -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \TChan Value
eventsChan TChan Value
ackChan -> do
      [String] -> (String -> App ()) -> App ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [String
handle1, String
handle2] ((String -> App ()) -> App ()) -> (String -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \String
handle ->
        TChan Value -> (HasCallStack => Value -> App ()) -> App ()
forall a.
HasCallStack =>
TChan Value -> (HasCallStack => Value -> App a) -> App a
assertEvent TChan Value
eventsChan ((HasCallStack => Value -> App ()) -> App ())
-> (HasCallStack => Value -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \Value
e -> do
          Value
e Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"data.event.payload.0.type" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"user.update"
          Value
e Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"data.event.payload.0.user.handle" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
handle
          HasCallStack => TChan Value -> Value -> App ()
TChan Value -> Value -> App ()
ackEvent TChan Value
ackChan Value
e

      HasCallStack => TChan Value -> App ()
TChan Value -> App ()
assertNoEvent TChan Value
eventsChan

----------------------------------------------------------------------
-- helpers

withEventsWebSockets :: forall uid a. (HasCallStack, MakesValue uid) => [(uid, String)] -> ([(TChan Value, TChan Value)] -> App a) -> App a
withEventsWebSockets :: forall uid a.
(HasCallStack, MakesValue uid) =>
[(uid, String)] -> ([(TChan Value, TChan Value)] -> App a) -> App a
withEventsWebSockets [(uid, String)]
userClients [(TChan Value, TChan Value)] -> App a
k = [(TChan Value, TChan Value)] -> [(uid, String)] -> App a
go [] ([(uid, String)] -> App a) -> [(uid, String)] -> App a
forall a b. (a -> b) -> a -> b
$ [(uid, String)] -> [(uid, String)]
forall a. [a] -> [a]
reverse [(uid, String)]
userClients
  where
    go :: [(TChan Value, TChan Value)] -> [(uid, String)] -> App a
    go :: [(TChan Value, TChan Value)] -> [(uid, String)] -> App a
go [(TChan Value, TChan Value)]
chans [] = [(TChan Value, TChan Value)] -> App a
k [(TChan Value, TChan Value)]
chans
    go [(TChan Value, TChan Value)]
chans ((uid
uid, String
cid) : [(uid, String)]
remaining) =
      uid -> String -> (TChan Value -> TChan Value -> App a) -> App a
forall uid a.
(HasCallStack, MakesValue uid) =>
uid -> String -> (TChan Value -> TChan Value -> App a) -> App a
withEventsWebSocket uid
uid String
cid ((TChan Value -> TChan Value -> App a) -> App a)
-> (TChan Value -> TChan Value -> App a) -> App a
forall a b. (a -> b) -> a -> b
$ \TChan Value
eventsChan TChan Value
ackChan ->
        [(TChan Value, TChan Value)] -> [(uid, String)] -> App a
go ((TChan Value
eventsChan, TChan Value
ackChan) (TChan Value, TChan Value)
-> [(TChan Value, TChan Value)] -> [(TChan Value, TChan Value)]
forall a. a -> [a] -> [a]
: [(TChan Value, TChan Value)]
chans) [(uid, String)]
remaining

withEventsWebSocket :: (HasCallStack, MakesValue uid) => uid -> String -> (TChan Value -> TChan Value -> App a) -> App a
withEventsWebSocket :: forall uid a.
(HasCallStack, MakesValue uid) =>
uid -> String -> (TChan Value -> TChan Value -> App a) -> App a
withEventsWebSocket uid
uid String
cid TChan Value -> TChan Value -> App a
k = do
  MVar ()
closeWS <- App (MVar ())
forall (m :: * -> *) a. MonadIO m => m (MVar a)
newEmptyMVar
  App (TChan Value, TChan Value, Async ())
-> ((TChan Value, TChan Value, Async ()) -> App ())
-> ((TChan Value, TChan Value, Async ()) -> App a)
-> App a
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket (HasCallStack => MVar () -> App (TChan Value, TChan Value, Async ())
MVar () -> App (TChan Value, TChan Value, Async ())
setup MVar ()
closeWS) (\(TChan Value
_, TChan Value
_, Async ()
wsThread) -> Async () -> App ()
forall (m :: * -> *) a. MonadIO m => Async a -> m ()
cancel Async ()
wsThread) (((TChan Value, TChan Value, Async ()) -> App a) -> App a)
-> ((TChan Value, TChan Value, Async ()) -> App a) -> App a
forall a b. (a -> b) -> a -> b
$ \(TChan Value
eventsChan, TChan Value
ackChan, Async ()
wsThread) -> do
    a
x <- TChan Value -> TChan Value -> App a
k TChan Value
eventsChan TChan Value
ackChan

    -- Ensure all the acks are sent before closing the websocket
    Bool
isAckChanEmpty <-
      RetryPolicyM App
-> (RetryStatus -> Bool -> App Bool)
-> (RetryStatus -> App Bool)
-> App Bool
forall (m :: * -> *) b.
MonadIO m =>
RetryPolicyM m
-> (RetryStatus -> b -> m Bool) -> (RetryStatus -> m b) -> m b
retrying
        (Int -> RetryPolicy
limitRetries Int
5 RetryPolicyM App -> RetryPolicyM App -> RetryPolicyM App
forall a. Semigroup a => a -> a -> a
<> Int -> RetryPolicyM App
forall (m :: * -> *). Monad m => Int -> RetryPolicyM m
constantDelay Int
10_000)
        (\RetryStatus
_ Bool
isEmpty -> Bool -> App Bool
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> App Bool) -> Bool -> App Bool
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not Bool
isEmpty)
        (\RetryStatus
_ -> STM Bool -> App Bool
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM Bool -> App Bool) -> STM Bool -> App Bool
forall a b. (a -> b) -> a -> b
$ TChan Value -> STM Bool
forall a. TChan a -> STM Bool
isEmptyTChan TChan Value
ackChan)
    Bool -> App () -> App ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
isAckChanEmpty (App () -> App ()) -> App () -> App ()
forall a b. (a -> b) -> a -> b
$ do
      String -> App ()
forall (m :: * -> *). MonadIO m => String -> m ()
putStrLn (String -> App ()) -> String -> App ()
forall a b. (a -> b) -> a -> b
$ String -> String -> String
colored String
yellow (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
"The ack chan is not empty after 50ms, some acks may not make it to the server"

    App Bool -> App ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (App Bool -> App ()) -> App Bool -> App ()
forall a b. (a -> b) -> a -> b
$ MVar () -> () -> App Bool
forall (m :: * -> *) a. MonadIO m => MVar a -> a -> m Bool
tryPutMVar MVar ()
closeWS ()

    Int -> App () -> App (Maybe ())
forall (m :: * -> *) a.
MonadUnliftIO m =>
Int -> m a -> m (Maybe a)
timeout Int
1_000_000 (Async () -> App ()
forall (m :: * -> *) a. MonadIO m => Async a -> m a
wait Async ()
wsThread) App (Maybe ()) -> (Maybe () -> 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 ()
Nothing ->
        String -> App ()
forall (m :: * -> *). MonadIO m => String -> m ()
putStrLn (String -> App ()) -> String -> App ()
forall a b. (a -> b) -> a -> b
$ String -> String -> String
colored String
yellow (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
"The websocket thread did not close after waiting for 1s"
      Just () -> () -> App ()
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

    a -> App a
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
  where
    setup :: (HasCallStack) => MVar () -> App (TChan Value, TChan Value, Async ())
    setup :: HasCallStack => MVar () -> App (TChan Value, TChan Value, Async ())
setup MVar ()
closeWS = do
      (TChan Value
eventsChan, TChan Value
ackChan) <- IO (TChan Value, TChan Value) -> App (TChan Value, TChan Value)
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (TChan Value, TChan Value) -> App (TChan Value, TChan Value))
-> IO (TChan Value, TChan Value) -> App (TChan Value, TChan Value)
forall a b. (a -> b) -> a -> b
$ (,) (TChan Value -> TChan Value -> (TChan Value, TChan Value))
-> IO (TChan Value)
-> IO (TChan Value -> (TChan Value, TChan Value))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (TChan Value)
forall (m :: * -> *) a. MonadIO m => m (TChan a)
newTChanIO IO (TChan Value -> (TChan Value, TChan Value))
-> IO (TChan Value) -> IO (TChan Value, TChan Value)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO (TChan Value)
forall (m :: * -> *) a. MonadIO m => m (TChan a)
newTChanIO
      Async ()
wsThread <- uid
-> String
-> TChan Value
-> TChan Value
-> MVar ()
-> App (Async ())
forall user.
MakesValue user =>
user
-> String
-> TChan Value
-> TChan Value
-> MVar ()
-> App (Async ())
eventsWebSocket uid
uid String
cid TChan Value
eventsChan TChan Value
ackChan MVar ()
closeWS
      (TChan Value, TChan Value, Async ())
-> App (TChan Value, TChan Value, Async ())
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TChan Value
eventsChan, TChan Value
ackChan, Async ()
wsThread)

sendMsg :: (HasCallStack) => TChan Value -> Value -> App ()
sendMsg :: HasCallStack => TChan Value -> Value -> App ()
sendMsg TChan Value
eventsChan Value
msg = 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 (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TChan Value -> Value -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan Value
eventsChan Value
msg

ackFullSync :: (HasCallStack) => TChan Value -> App ()
ackFullSync :: HasCallStack => TChan Value -> App ()
ackFullSync TChan Value
ackChan = do
  HasCallStack => TChan Value -> Value -> App ()
TChan Value -> Value -> App ()
sendMsg TChan Value
ackChan
    (Value -> App ()) -> Value -> App ()
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object [String
"type" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= String
"ack_full_sync"]

ackEvent :: (HasCallStack) => TChan Value -> Value -> App ()
ackEvent :: HasCallStack => TChan Value -> Value -> App ()
ackEvent TChan Value
ackChan Value
event = do
  Value
deliveryTag <- Value
event Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"data.delivery_tag"
  HasCallStack => TChan Value -> Value -> Bool -> App ()
TChan Value -> Value -> Bool -> App ()
sendAck TChan Value
ackChan Value
deliveryTag Bool
False

sendAck :: (HasCallStack) => TChan Value -> Value -> Bool -> App ()
sendAck :: HasCallStack => TChan Value -> Value -> Bool -> App ()
sendAck TChan Value
ackChan Value
deliveryTag Bool
multiple = do
  HasCallStack => TChan Value -> Value -> App ()
TChan Value -> Value -> App ()
sendMsg TChan Value
ackChan
    (Value -> App ()) -> Value -> App ()
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object
      [ String
"type" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= String
"ack",
        String
"data"
          String -> Value -> Pair
forall a. ToJSON a => String -> a -> Pair
.= [Pair] -> Value
object
            [ String
"delivery_tag" String -> Value -> Pair
forall a. ToJSON a => String -> a -> Pair
.= Value
deliveryTag,
              String
"multiple" String -> Bool -> Pair
forall a. ToJSON a => String -> a -> Pair
.= Bool
multiple
            ]
      ]

assertEvent :: (HasCallStack) => TChan Value -> ((HasCallStack) => Value -> App a) -> App a
assertEvent :: forall a.
HasCallStack =>
TChan Value -> (HasCallStack => Value -> App a) -> App a
assertEvent TChan Value
eventsChan HasCallStack => Value -> App a
expectations = do
  Int -> App Value -> App (Maybe Value)
forall (m :: * -> *) a.
MonadUnliftIO m =>
Int -> m a -> m (Maybe a)
timeout Int
10_000_000 (STM Value -> App Value
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TChan Value -> STM Value
forall a. TChan a -> STM a
readTChan TChan Value
eventsChan)) App (Maybe Value) -> (Maybe Value -> App a) -> App a
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 -> String -> App a
forall a. HasCallStack => String -> App a
assertFailure String
"No event received for 10s"
    Just Value
e -> do
      String
pretty <- Value -> App String
forall a. MakesValue a => a -> App String
prettyJSON Value
e
      String -> App a -> App a
forall a. String -> App a -> App a
addFailureContext (String
"event:\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
pretty)
        (App a -> App a) -> App a -> App a
forall a b. (a -> b) -> a -> b
$ HasCallStack => Value -> App a
Value -> App a
expectations Value
e

assertNoEvent :: (HasCallStack) => TChan Value -> App ()
assertNoEvent :: HasCallStack => TChan Value -> App ()
assertNoEvent TChan Value
eventsChan = do
  Int -> App Value -> App (Maybe Value)
forall (m :: * -> *) a.
MonadUnliftIO m =>
Int -> m a -> m (Maybe a)
timeout Int
1_000_000 (STM Value -> App Value
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TChan Value -> STM Value
forall a. TChan a -> STM a
readTChan TChan Value
eventsChan)) 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
e -> do
      String
eventJSON <- Value -> App String
forall a. MakesValue a => a -> App String
prettyJSON Value
e
      String -> App ()
forall a. HasCallStack => String -> App a
assertFailure (String -> App ()) -> String -> App ()
forall a b. (a -> b) -> a -> b
$ String
"Did not expect event: \n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
eventJSON

consumeAllEvents :: TChan Value -> TChan Value -> App ()
consumeAllEvents :: TChan Value -> TChan Value -> App ()
consumeAllEvents TChan Value
eventsChan TChan Value
ackChan = do
  Int -> App Value -> App (Maybe Value)
forall (m :: * -> *) a.
MonadUnliftIO m =>
Int -> m a -> m (Maybe a)
timeout Int
1_000_000 (STM Value -> App Value
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TChan Value -> STM Value
forall a. TChan a -> STM a
readTChan TChan Value
eventsChan)) 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
e -> do
      HasCallStack => TChan Value -> Value -> App ()
TChan Value -> Value -> App ()
ackEvent TChan Value
ackChan Value
e
      TChan Value -> TChan Value -> App ()
consumeAllEvents TChan Value
eventsChan TChan Value
ackChan

eventsWebSocket :: (MakesValue user) => user -> String -> TChan Value -> TChan Value -> MVar () -> App (Async ())
eventsWebSocket :: forall user.
MakesValue user =>
user
-> String
-> TChan Value
-> TChan Value
-> MVar ()
-> App (Async ())
eventsWebSocket user
user String
clientId TChan Value
eventsChan TChan Value
ackChan MVar ()
closeWS = do
  ServiceMap
serviceMap <- HasCallStack => String -> App ServiceMap
String -> App ServiceMap
getServiceMap (String -> App ServiceMap) -> App String -> App ServiceMap
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< user -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
objDomain user
user
  String
uid <- Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
objId (Value -> App String) -> App Value -> App String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< user -> App Value
forall a. (HasCallStack, MakesValue a) => a -> App Value
objQidObject user
user
  let HostPort String
caHost Word16
caPort = ServiceMap -> Service -> HostPort
serviceHostPort ServiceMap
serviceMap Service
Cannon
      path :: String
path = String
"/events?client=" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
clientId
      caHdrs :: [(CI ByteString, ByteString)]
caHdrs = [(String -> CI ByteString
forall a. IsString a => String -> a
fromString String
"Z-User", String -> ByteString
forall a. ToByteString a => a -> ByteString
toByteString' String
uid)]
      app :: Connection -> IO ()
app Connection
conn = do
        Async ()
r <-
          IO () -> IO (Async ())
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ Connection -> IO ()
wsRead Connection
conn IO () -> (ConnectionException -> IO ()) -> IO ()
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \(ConnectionException
e :: WS.ConnectionException) ->
            case ConnectionException
e of
              WS.CloseRequest {} -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
              ConnectionException
_ -> ConnectionException -> IO ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO ConnectionException
e
        Async ()
w <- IO () -> IO (Async ())
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ Connection -> IO ()
wsWrite Connection
conn
        IO (Async (), ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Async (), ()) -> IO ()) -> IO (Async (), ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ [Async ()] -> IO (Async (), ())
forall (m :: * -> *) a. MonadIO m => [Async a] -> m (Async a, a)
waitAny [Async ()
r, Async ()
w]

      wsRead :: Connection -> IO ()
wsRead Connection
conn = IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        ByteString
bs <- Connection -> IO ByteString
forall a. WebSocketsData a => Connection -> IO a
WS.receiveData Connection
conn
        case ByteString -> Maybe Value
forall a. FromJSON a => ByteString -> Maybe a
decodeStrict' ByteString
bs of
          Just Value
n -> STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TChan Value -> Value -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan Value
eventsChan Value
n
          Maybe Value
Nothing ->
            String -> IO ()
forall a. HasCallStack => String -> a
error (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Failed to decode events: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ByteString -> String
forall a. Show a => a -> String
show ByteString
bs

      wsWrite :: Connection -> IO ()
wsWrite Connection
conn = IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Either () Value
eitherAck <- IO () -> IO Value -> IO (Either () Value)
forall (m :: * -> *) a b.
MonadUnliftIO m =>
m a -> m b -> m (Either a b)
race (MVar () -> IO ()
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
readMVar MVar ()
closeWS) (STM Value -> IO Value
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM Value -> IO Value) -> STM Value -> IO Value
forall a b. (a -> b) -> a -> b
$ TChan Value -> STM Value
forall a. TChan a -> STM a
readTChan TChan Value
ackChan)
        case Either () Value
eitherAck of
          Left () -> Connection -> Text -> IO ()
forall a. WebSocketsData a => Connection -> a -> IO ()
WS.sendClose Connection
conn (String -> Text
Text.pack String
"")
          Right Value
ack -> Connection -> ByteString -> IO ()
forall a. WebSocketsData a => Connection -> a -> IO ()
WS.sendBinaryData Connection
conn (Value -> ByteString
forall a. ToJSON a => a -> ByteString
encode Value
ack)
  IO (Async ()) -> App (Async ())
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
    (IO (Async ()) -> App (Async ()))
-> IO (Async ()) -> App (Async ())
forall a b. (a -> b) -> a -> b
$ IO () -> IO (Async ())
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
async
    (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ String
-> Int
-> String
-> ConnectionOptions
-> [(CI ByteString, ByteString)]
-> (Connection -> IO ())
-> IO ()
forall a.
String
-> Int
-> String
-> ConnectionOptions
-> [(CI ByteString, ByteString)]
-> ClientApp a
-> IO a
WS.runClientWith
      String
caHost
      (Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
caPort)
      String
path
      ConnectionOptions
WS.defaultConnectionOptions
      [(CI ByteString, ByteString)]
caHdrs
      Connection -> IO ()
app