{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

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

module Testlib.Cannon
  ( WebSocket (..),
    WSConnect (..),
    ToWSConnect (..),
    AwaitResult (..),
    withWebSocket,
    withWebSockets,
    awaitNMatchesResult,
    awaitNMatches,
    awaitMatch,
    awaitAnyEvent,
    awaitAtLeastNMatchesResult,
    awaitAtLeastNMatches,
    awaitNToMMatchesResult,
    awaitNToMMatches,
    assertAwaitResult,
    nPayload,
    printAwaitResult,
    printAwaitAtLeastResult,
    waitForResponse,
    assertNoEvent,
  )
where

import Control.Concurrent
import Control.Concurrent.Async
import Control.Concurrent.STM.TChan
import Control.Exception (throwIO)
import qualified Control.Exception as E
import Control.Monad
import Control.Monad.Catch hiding (bracket)
import qualified Control.Monad.Catch as Catch
import Control.Monad.IO.Class
import Control.Monad.Reader (asks)
import Control.Monad.STM
import Data.Aeson hiding ((.=))
import Data.ByteString (ByteString)
import Data.ByteString.Conversion (fromByteString)
import Data.ByteString.Conversion.To
import Data.Function
import Data.Maybe
import Data.Traversable
import Data.Word
import GHC.Records
import GHC.Stack
import qualified Network.HTTP.Client as HTTP
import qualified Network.HTTP.Client as Http
import qualified Network.WebSockets as WS
import System.Random (randomIO)
import System.Timeout (timeout)
import Testlib.App
import Testlib.Assertions
import Testlib.Env
import Testlib.HTTP
import Testlib.JSON
import Testlib.Printing
import Testlib.Types
import UnliftIO (withRunInIO)
import Prelude

data WebSocket = WebSocket
  { WebSocket -> WSConnect
wsConnect :: WSConnect,
    WebSocket -> TChan Value
wsChan :: TChan Value,
    WebSocket -> MVar ()
wsCloseLatch :: MVar (),
    WebSocket -> Async ()
wsAppThread :: Async ()
  }

instance HasField "client" WebSocket (Maybe ClientIdentity) where
  getField :: WebSocket -> Maybe ClientIdentity
getField WebSocket
ws = do
    String
c <- WebSocket
ws.wsConnect.client
    ClientIdentity -> Maybe ClientIdentity
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      ClientIdentity
        { $sel:domain:ClientIdentity :: String
domain = WebSocket
ws.wsConnect.domain,
          $sel:user:ClientIdentity :: String
user = WebSocket
ws.wsConnect.user,
          $sel:client:ClientIdentity :: String
client = String
c
        }

instance HasField "user" WebSocket Value where
  getField :: WebSocket -> Value
getField WebSocket
ws =
    [Pair] -> Value
object
      [ String
"domain" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= WebSocket
ws.wsConnect.domain,
        String
"id" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= WebSocket
ws.wsConnect.user
      ]

-- Specifies how a Websocket at cannon should be opened
data WSConnect = WSConnect
  { WSConnect -> String
user :: String,
    WSConnect -> String
domain :: String,
    WSConnect -> Maybe String
client :: Maybe String,
    -- | If this is Nothing then a random Z-Connection will be used
    WSConnect -> Maybe String
conn :: Maybe String
  }

class ToWSConnect a where
  toWSConnect :: (HasCallStack) => a -> App WSConnect

instance {-# OVERLAPPING #-} ToWSConnect WSConnect where
  toWSConnect :: HasCallStack => WSConnect -> App WSConnect
toWSConnect = WSConnect -> App WSConnect
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

instance {-# OVERLAPPABLE #-} (MakesValue user) => ToWSConnect user where
  toWSConnect :: HasCallStack => user -> App WSConnect
toWSConnect user
u = do
    (String
domain, String
uid) <- user -> App (String, String)
forall a. (HasCallStack, MakesValue a) => a -> App (String, String)
objQid user
u
    Maybe Value
mc <- user -> String -> App (Maybe Value)
forall a.
(HasCallStack, MakesValue a) =>
a -> String -> App (Maybe Value)
lookupField user
u String
"client_id"
    Maybe String
c <- (Value -> App String) -> Maybe Value -> App (Maybe String)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString Maybe Value
mc
    WSConnect -> App WSConnect
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> String -> Maybe String -> Maybe String -> WSConnect
WSConnect String
uid String
domain Maybe String
c Maybe String
forall a. Maybe a
Nothing)

instance (MakesValue user, MakesValue conn) => ToWSConnect (user, conn) where
  toWSConnect :: HasCallStack => (user, conn) -> App WSConnect
toWSConnect (user
u, conn
c) = do
    (String
domain, String
uid) <- user -> App (String, String)
forall a. (HasCallStack, MakesValue a) => a -> App (String, String)
objQid user
u
    String
conn <- conn -> App Value
forall a. (MakesValue a, HasCallStack) => a -> App Value
make conn
c 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
    WSConnect -> App WSConnect
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> String -> Maybe String -> Maybe String -> WSConnect
WSConnect String
uid String
domain Maybe String
forall a. Maybe a
Nothing (String -> Maybe String
forall a. a -> Maybe a
Just String
conn))

instance (MakesValue user, MakesValue conn, MakesValue client) => ToWSConnect (user, conn, client) where
  toWSConnect :: HasCallStack => (user, conn, client) -> App WSConnect
toWSConnect (user
u, conn
c, client
cl) = do
    (String
domain, String
uid) <- user -> App (String, String)
forall a. (HasCallStack, MakesValue a) => a -> App (String, String)
objQid user
u
    String
client <- client -> App Value
forall a. (MakesValue a, HasCallStack) => a -> App Value
make client
cl 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
    String
conn <- conn -> App Value
forall a. (MakesValue a, HasCallStack) => a -> App Value
make conn
c 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
    WSConnect -> App WSConnect
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> String -> Maybe String -> Maybe String -> WSConnect
WSConnect String
uid String
domain (String -> Maybe String
forall a. a -> Maybe a
Just String
client) (String -> Maybe String
forall a. a -> Maybe a
Just String
conn))

connect :: (HasCallStack) => WSConnect -> App WebSocket
connect :: HasCallStack => WSConnect -> App WebSocket
connect WSConnect
wsConnect = do
  TChan Value
nchan <- IO (TChan Value) -> App (TChan Value)
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (TChan Value)
forall a. IO (TChan a)
newTChanIO
  MVar ()
latch <- IO (MVar ()) -> App (MVar ())
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
  Async ()
wsapp <- HasCallStack => WSConnect -> ClientApp () -> App (Async ())
WSConnect -> ClientApp () -> App (Async ())
run WSConnect
wsConnect (HasCallStack => TChan Value -> MVar () -> ClientApp ()
TChan Value -> MVar () -> ClientApp ()
clientApp TChan Value
nchan MVar ()
latch)
  WebSocket -> App WebSocket
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (WebSocket -> App WebSocket) -> WebSocket -> App WebSocket
forall a b. (a -> b) -> a -> b
$ WSConnect -> TChan Value -> MVar () -> Async () -> WebSocket
WebSocket WSConnect
wsConnect TChan Value
nchan MVar ()
latch Async ()
wsapp

clientApp :: (HasCallStack) => TChan Value -> MVar () -> WS.ClientApp ()
clientApp :: HasCallStack => TChan Value -> MVar () -> ClientApp ()
clientApp TChan Value
wsChan MVar ()
latch Connection
conn = do
  Async Any
r <- IO Any -> IO (Async Any)
forall a. IO a -> IO (Async a)
async IO Any
wsRead
  Async Any
w <- IO Any -> IO (Async Any)
forall a. IO a -> IO (Async a)
async IO Any
wsWrite
  IO (Either Any Any) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either Any Any) -> IO ()) -> IO (Either Any Any) -> IO ()
forall a b. (a -> b) -> a -> b
$ Async Any -> Async Any -> IO (Either Any Any)
forall a b. Async a -> Async b -> IO (Either a b)
waitEitherCancel Async Any
r Async Any
w
  where
    wsRead :: IO Any
wsRead = IO () -> IO Any
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO Any) -> IO () -> IO Any
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 a. STM a -> IO 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
wsChan Value
n
        Maybe Value
Nothing -> String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Failed to decode notification: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ByteString -> String
forall a. Show a => a -> String
show ByteString
bs
    wsWrite :: IO Any
wsWrite = IO () -> IO Any
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO Any) -> IO () -> IO Any
forall a b. (a -> b) -> a -> b
$ do
      MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
latch
      Connection -> ByteString -> IO ()
forall a. WebSocketsData a => Connection -> a -> IO ()
WS.sendClose Connection
conn (ByteString
"close" :: ByteString)

-- | Start a client thread in 'Async' that opens a web socket to a Cannon, wait
--   for the connection to register with Gundeck, and return the 'Async' thread.
run ::
  (HasCallStack) =>
  WSConnect ->
  WS.ClientApp () ->
  App (Async ())
run :: HasCallStack => WSConnect -> ClientApp () -> App (Async ())
run WSConnect
wsConnect ClientApp ()
app = do
  String
domain <- String -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString WSConnect
wsConnect.domain
  ServiceMap
serviceMap <- HasCallStack => String -> App ServiceMap
String -> App ServiceMap
getServiceMap String
domain

  let HostPort String
caHost Word16
caPort = ServiceMap -> Service -> HostPort
serviceHostPort ServiceMap
serviceMap Service
Cannon
  MVar SomeException
latch <- IO (MVar SomeException) -> App (MVar SomeException)
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (MVar SomeException)
forall a. IO (MVar a)
newEmptyMVar

  String
connId <- case WSConnect
wsConnect.conn of
    Just String
c -> String -> App String
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
c
    Maybe String
Nothing -> Word32 -> String
forall a. Show a => a -> String
show (Word32 -> String) -> App Word32 -> App String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Word32 -> App Word32
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Word32
forall a (m :: * -> *). (Random a, MonadIO m) => m a
randomIO :: IO Word32)

  let path :: String
path =
        String
"/await"
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ( case WSConnect
wsConnect.client of
                 Maybe String
Nothing -> String
""
                 Just String
client -> Maybe String -> String
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe String -> String)
-> (ByteString -> Maybe String) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Maybe String
forall a. FromByteString a => ByteString -> Maybe a
fromByteString (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
Http.queryString ([(ByteString, Maybe ByteString)] -> Request -> Request
Http.setQueryString [(ByteString
"client", ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (String -> ByteString
forall a. ToByteString a => a -> ByteString
toByteString' String
client))] Request
Http.defaultRequest)
             )
      caHdrs :: [Header]
caHdrs =
        [ (HeaderName
"Z-User", String -> ByteString
forall a. ToByteString a => a -> ByteString
toByteString' (WSConnect
wsConnect.user)),
          (HeaderName
"Z-Connection", String -> ByteString
forall a. ToByteString a => a -> ByteString
toByteString' String
connId)
        ]
  Request
request <- do
    Request
r <- String -> Service -> Versioned -> String -> App Request
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Service -> Versioned -> String -> App Request
rawBaseRequest String
domain Service
Cannon Versioned
Versioned String
path
    Request -> App Request
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Request
r {HTTP.requestHeaders = caHdrs}

  Async ()
wsapp <-
    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 a. IO a -> IO (Async a)
async
      (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ IO () -> (SomeException -> IO ()) -> IO ()
forall e a.
(HasCallStack, Exception e) =>
IO a -> (e -> IO a) -> IO a
forall (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
m a -> (e -> m a) -> m a
catch
        ( String
-> Int
-> String
-> ConnectionOptions
-> [Header]
-> ClientApp ()
-> IO ()
forall a.
String
-> Int
-> String
-> ConnectionOptions
-> [Header]
-> 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
            [Header]
caHdrs
            ClientApp ()
app
        )
      ((SomeException -> IO ()) -> IO ())
-> (SomeException -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(SomeException
e :: SomeException) -> MVar SomeException -> SomeException -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar SomeException
latch SomeException
e

  Request
presenceRequest <-
    String -> Service -> Versioned -> String -> App Request
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Service -> Versioned -> String -> App Request
baseRequest String
domain Service
Cannon Versioned
Unversioned (String -> App Request) -> String -> App Request
forall a b. (a -> b) -> a -> b
$
      String
"/i/presences/" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> WSConnect
wsConnect.user String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"/" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
connId

  IO ()
waitForPresence <- App () -> App (IO ())
forall a. App a -> App (IO a)
appToIO (App () -> App (IO ())) -> App () -> App (IO ())
forall a b. (a -> b) -> a -> b
$ App () -> App ()
forall a. App a -> App a
retryT (App () -> App ()) -> App () -> App ()
forall a b. (a -> b) -> a -> b
$ do
    Response
response <- String -> Request -> App Response
submit String
"HEAD" Request
presenceRequest
    Response -> Int
status Response
response Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
  let waitForException :: IO Any
waitForException = do
        SomeException
ex <- MVar SomeException -> IO SomeException
forall a. MVar a -> IO a
takeMVar MVar SomeException
latch
        -- Construct a "fake" response. We do not really have access to the
        -- websocket connection requests and response, unfortunately, but it is
        -- useful to display some information about the request in case an
        -- exception occurs.
        let r :: Response
r =
              Response
                { $sel:jsonBody:Response :: Maybe Value
jsonBody = Maybe Value
forall a. Maybe a
Nothing,
                  $sel:body:Response :: ByteString
body = ByteString
"This is a fake response. The actual response from cannon is not available.",
                  $sel:status:Response :: Int
status = Int
101,
                  $sel:headers:Response :: [Header]
headers = [Header]
forall a. Monoid a => a
mempty,
                  $sel:request:Response :: Request
request = Request
request
                }
        AssertionFailure -> IO Any
forall e a. Exception e => e -> IO a
throwIO (CallStack
-> Maybe Response -> Maybe String -> String -> AssertionFailure
AssertionFailure CallStack
HasCallStack => CallStack
callStack (Response -> Maybe Response
forall a. a -> Maybe a
Just Response
r) Maybe String
forall a. Maybe a
Nothing (SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
ex))

  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
$ IO () -> IO Any -> IO ()
forall a b. IO a -> IO b -> IO ()
race_ IO ()
waitForPresence IO Any
waitForException
  Async () -> App (Async ())
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Async ()
wsapp

close :: (MonadIO m) => WebSocket -> m ()
close :: forall (m :: * -> *). MonadIO m => WebSocket -> m ()
close WebSocket
ws = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar (WebSocket -> MVar ()
wsCloseLatch WebSocket
ws) ()
  IO (Either SomeException ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either SomeException ()) -> IO ())
-> IO (Either SomeException ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Async () -> IO (Either SomeException ())
forall a. Async a -> IO (Either SomeException a)
waitCatch (WebSocket -> Async ()
wsAppThread WebSocket
ws)

withWebSocket :: (HasCallStack, ToWSConnect w) => w -> (WebSocket -> App a) -> App a
withWebSocket :: forall w a.
(HasCallStack, ToWSConnect w) =>
w -> (WebSocket -> App a) -> App a
withWebSocket w
w WebSocket -> App a
k = do
  WSConnect
wsConnect <- w -> App WSConnect
forall a. (ToWSConnect a, HasCallStack) => a -> App WSConnect
toWSConnect w
w
  App WebSocket
-> (WebSocket -> App ()) -> (WebSocket -> App a) -> App a
forall (m :: * -> *) a c b.
(HasCallStack, MonadMask m) =>
m a -> (a -> m c) -> (a -> m b) -> m b
Catch.bracket (HasCallStack => WSConnect -> App WebSocket
WSConnect -> App WebSocket
connect WSConnect
wsConnect) WebSocket -> App ()
forall (m :: * -> *). MonadIO m => WebSocket -> m ()
close WebSocket -> App a
k

withWebSockets :: forall a w. (HasCallStack, ToWSConnect w) => [w] -> ([WebSocket] -> App a) -> App a
withWebSockets :: forall a w.
(HasCallStack, ToWSConnect w) =>
[w] -> ([WebSocket] -> App a) -> App a
withWebSockets [w]
twcs [WebSocket] -> App a
k = do
  [WSConnect]
wcs <- [w] -> (w -> App WSConnect) -> App [WSConnect]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [w]
twcs w -> App WSConnect
forall a. (ToWSConnect a, HasCallStack) => a -> App WSConnect
toWSConnect
  HasCallStack => [WSConnect] -> [WebSocket] -> App a
[WSConnect] -> [WebSocket] -> App a
go [WSConnect]
wcs []
  where
    go :: (HasCallStack) => [WSConnect] -> [WebSocket] -> App a
    go :: HasCallStack => [WSConnect] -> [WebSocket] -> App a
go [] [WebSocket]
wss = [WebSocket] -> App a
k ([WebSocket] -> [WebSocket]
forall a. [a] -> [a]
reverse [WebSocket]
wss)
    go (WSConnect
wc : [WSConnect]
wcs) [WebSocket]
wss = WSConnect -> (WebSocket -> App a) -> App a
forall w a.
(HasCallStack, ToWSConnect w) =>
w -> (WebSocket -> App a) -> App a
withWebSocket WSConnect
wc (\WebSocket
ws -> HasCallStack => [WSConnect] -> [WebSocket] -> App a
[WSConnect] -> [WebSocket] -> App a
go [WSConnect]
wcs (WebSocket
ws WebSocket -> [WebSocket] -> [WebSocket]
forall a. a -> [a] -> [a]
: [WebSocket]
wss))

data AwaitResult = AwaitResult
  { AwaitResult -> Bool
success :: Bool,
    AwaitResult -> Int
nMatchesExpected :: Int,
    AwaitResult -> [Value]
matches :: [Value],
    AwaitResult -> [Value]
nonMatches :: [Value]
  }

data AwaitAtLeastResult = AwaitAtLeastResult
  { AwaitAtLeastResult -> Bool
success :: Bool,
    AwaitAtLeastResult -> Int
nMatchesExpectedMin :: Int,
    AwaitAtLeastResult -> Maybe Int
nMatchesExpectedMax :: Maybe Int,
    AwaitAtLeastResult -> [Value]
matches :: [Value],
    AwaitAtLeastResult -> [Value]
nonMatches :: [Value]
  }

prettyAwaitResult :: AwaitResult -> App String
prettyAwaitResult :: AwaitResult -> App String
prettyAwaitResult AwaitResult
r = do
  [String]
matchesS <- [Value] -> (Value -> App String) -> App [String]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for AwaitResult
r.matches Value -> App String
forall a. MakesValue a => a -> App String
prettyJSON
  [String]
nonMatchesS <- [Value] -> (Value -> App String) -> App [String]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for AwaitResult
r.nonMatches Value -> App String
forall a. MakesValue a => a -> App String
prettyJSON
  String -> App String
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> App String) -> String -> App String
forall a b. (a -> b) -> a -> b
$
    String
"AwaitResult\n"
      String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String -> String
indent
        Int
4
        ( [String] -> String
unlines
            [ String
"success: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Bool -> String
forall a. Show a => a -> String
show (AwaitResult
r.success),
              String
"matches:\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [String] -> String
unlines [String]
matchesS,
              String
"non-matches:\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [String] -> String
unlines [String]
nonMatchesS
            ]
        )

prettyAwaitAtLeastResult :: AwaitAtLeastResult -> App String
prettyAwaitAtLeastResult :: AwaitAtLeastResult -> App String
prettyAwaitAtLeastResult AwaitAtLeastResult
r = do
  [String]
matchesS <- [Value] -> (Value -> App String) -> App [String]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for AwaitAtLeastResult
r.matches Value -> App String
forall a. MakesValue a => a -> App String
prettyJSON
  [String]
nonMatchesS <- [Value] -> (Value -> App String) -> App [String]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for AwaitAtLeastResult
r.nonMatches Value -> App String
forall a. MakesValue a => a -> App String
prettyJSON
  String -> App String
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> App String) -> String -> App String
forall a b. (a -> b) -> a -> b
$
    String
"AwaitAtLeastResult\n"
      String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String -> String
indent
        Int
4
        ( [String] -> String
unlines
            [ String
"min expected:" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show AwaitAtLeastResult
r.nMatchesExpectedMin,
              String
"max expected:" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Maybe Int -> String
forall a. Show a => a -> String
show AwaitAtLeastResult
r.nMatchesExpectedMax,
              String
"success: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Bool -> String
forall a. Show a => a -> String
show (AwaitAtLeastResult
r.success),
              String
"matches:\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [String] -> String
unlines [String]
matchesS,
              String
"non-matches:\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [String] -> String
unlines [String]
nonMatchesS
            ]
        )

printAwaitResult :: AwaitResult -> App ()
printAwaitResult :: AwaitResult -> App ()
printAwaitResult = AwaitResult -> App String
prettyAwaitResult (AwaitResult -> App String)
-> (String -> App ()) -> AwaitResult -> App ()
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> IO () -> App ()
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> App ()) -> (String -> IO ()) -> String -> App ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
putStrLn

printAwaitAtLeastResult :: AwaitAtLeastResult -> App ()
printAwaitAtLeastResult :: AwaitAtLeastResult -> App ()
printAwaitAtLeastResult = AwaitAtLeastResult -> App String
prettyAwaitAtLeastResult (AwaitAtLeastResult -> App String)
-> (String -> App ()) -> AwaitAtLeastResult -> App ()
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> IO () -> App ()
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> App ()) -> (String -> IO ()) -> String -> App ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
putStrLn

awaitAnyEvent :: Int -> WebSocket -> App (Maybe Value)
awaitAnyEvent :: Int -> WebSocket -> App (Maybe Value)
awaitAnyEvent Int
tSecs = IO (Maybe Value) -> App (Maybe Value)
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Value) -> App (Maybe Value))
-> (WebSocket -> IO (Maybe Value))
-> WebSocket
-> App (Maybe Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> IO Value -> IO (Maybe Value)
forall a. Int -> IO a -> IO (Maybe a)
timeout (Int
tSecs Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000) (IO Value -> IO (Maybe Value))
-> (WebSocket -> IO Value) -> WebSocket -> IO (Maybe Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM Value -> IO Value
forall a. STM a -> IO a
atomically (STM Value -> IO Value)
-> (WebSocket -> STM Value) -> WebSocket -> IO Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TChan Value -> STM Value
forall a. TChan a -> STM a
readTChan (TChan Value -> STM Value)
-> (WebSocket -> TChan Value) -> WebSocket -> STM Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WebSocket -> TChan Value
wsChan

-- | 'await' an expected number of notification events on the websocket that
-- satisfy the provided predicate. If there isn't any new event (matching or
-- non-matching) for a 'tSecs' seconds then AwaitResult is a failure. This
-- function will never terminate if there is a constant stream of events
-- received. When this functions returns it will push any non-matching
-- events back to the websocket.
awaitNMatchesResult ::
  (HasCallStack) =>
  -- | Number of matches
  Int ->
  -- | Selection function. Exceptions are *not* caught.
  (Value -> App Bool) ->
  WebSocket ->
  App AwaitResult
awaitNMatchesResult :: HasCallStack =>
Int -> (Value -> App Bool) -> WebSocket -> App AwaitResult
awaitNMatchesResult Int
nExpected Value -> App Bool
checkMatch WebSocket
ws = Int -> [Value] -> [Value] -> App AwaitResult
go Int
nExpected [] []
  where
    go :: Int -> [Value] -> [Value] -> App AwaitResult
go Int
0 [Value]
nonMatches [Value]
matches = do
      [Value] -> App ()
refill [Value]
nonMatches
      AwaitResult -> App AwaitResult
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AwaitResult -> App AwaitResult) -> AwaitResult -> App AwaitResult
forall a b. (a -> b) -> a -> b
$
        AwaitResult
          { $sel:success:AwaitResult :: Bool
success = Bool
True,
            $sel:nMatchesExpected:AwaitResult :: Int
nMatchesExpected = Int
nExpected,
            $sel:matches:AwaitResult :: [Value]
matches = [Value] -> [Value]
forall a. [a] -> [a]
reverse [Value]
matches,
            $sel:nonMatches:AwaitResult :: [Value]
nonMatches = [Value] -> [Value]
forall a. [a] -> [a]
reverse [Value]
nonMatches
          }
    go Int
nLeft [Value]
nonMatches [Value]
matches = do
      Int
tSecs <- (Env -> Int) -> App Int
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> Int
timeOutSeconds
      Maybe Value
mEvent <- Int -> WebSocket -> App (Maybe Value)
awaitAnyEvent Int
tSecs WebSocket
ws
      case Maybe Value
mEvent of
        Just Value
event ->
          do
            Bool
isMatch <- Value -> App Bool
checkMatch Value
event
            if Bool
isMatch
              then Int -> [Value] -> [Value] -> App AwaitResult
go (Int
nLeft Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [Value]
nonMatches (Value
event Value -> [Value] -> [Value]
forall a. a -> [a] -> [a]
: [Value]
matches)
              else Int -> [Value] -> [Value] -> App AwaitResult
go Int
nLeft (Value
event Value -> [Value] -> [Value]
forall a. a -> [a] -> [a]
: [Value]
nonMatches) [Value]
matches
        Maybe Value
Nothing -> do
          [Value] -> App ()
refill [Value]
nonMatches
          AwaitResult -> App AwaitResult
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AwaitResult -> App AwaitResult) -> AwaitResult -> App AwaitResult
forall a b. (a -> b) -> a -> b
$
            AwaitResult
              { $sel:success:AwaitResult :: Bool
success = Bool
False,
                $sel:nMatchesExpected:AwaitResult :: Int
nMatchesExpected = Int
nExpected,
                $sel:matches:AwaitResult :: [Value]
matches = [Value] -> [Value]
forall a. [a] -> [a]
reverse [Value]
matches,
                $sel:nonMatches:AwaitResult :: [Value]
nonMatches = [Value] -> [Value]
forall a. [a] -> [a]
reverse [Value]
nonMatches
              }
    refill :: [Value] -> App ()
refill = (Value -> App ()) -> [Value] -> App ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (IO () -> App ()
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> App ()) -> (Value -> IO ()) -> Value -> App ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> (Value -> STM ()) -> Value -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TChan Value -> Value -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan (WebSocket -> TChan Value
wsChan WebSocket
ws))

awaitAtLeastNMatchesResult ::
  (HasCallStack) =>
  -- | Minimum number of matches
  Int ->
  -- | Selection function. Exceptions are *not* caught.
  (Value -> App Bool) ->
  WebSocket ->
  App AwaitAtLeastResult
awaitAtLeastNMatchesResult :: HasCallStack =>
Int -> (Value -> App Bool) -> WebSocket -> App AwaitAtLeastResult
awaitAtLeastNMatchesResult Int
nExpected Value -> App Bool
checkMatch WebSocket
ws = Int -> [Value] -> [Value] -> App AwaitAtLeastResult
go Int
0 [] []
  where
    go :: Int -> [Value] -> [Value] -> App AwaitAtLeastResult
go Int
nSeen [Value]
nonMatches [Value]
matches = do
      Int
tSecs <- (Env -> Int) -> App Int
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> Int
timeOutSeconds
      Maybe Value
mEvent <- Int -> WebSocket -> App (Maybe Value)
awaitAnyEvent Int
tSecs WebSocket
ws
      case Maybe Value
mEvent of
        Just Value
event ->
          do
            Bool
isMatch <- Value -> App Bool
checkMatch Value
event
            if Bool
isMatch
              then Int -> [Value] -> [Value] -> App AwaitAtLeastResult
go (Int
nSeen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [Value]
nonMatches (Value
event Value -> [Value] -> [Value]
forall a. a -> [a] -> [a]
: [Value]
matches)
              else Int -> [Value] -> [Value] -> App AwaitAtLeastResult
go Int
nSeen (Value
event Value -> [Value] -> [Value]
forall a. a -> [a] -> [a]
: [Value]
nonMatches) [Value]
matches
        Maybe Value
Nothing -> do
          [Value] -> App ()
refill [Value]
nonMatches
          AwaitAtLeastResult -> App AwaitAtLeastResult
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AwaitAtLeastResult -> App AwaitAtLeastResult)
-> AwaitAtLeastResult -> App AwaitAtLeastResult
forall a b. (a -> b) -> a -> b
$
            AwaitAtLeastResult
              { $sel:success:AwaitAtLeastResult :: Bool
success = Int
nSeen Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
nExpected,
                $sel:nMatchesExpectedMin:AwaitAtLeastResult :: Int
nMatchesExpectedMin = Int
nExpected,
                $sel:nMatchesExpectedMax:AwaitAtLeastResult :: Maybe Int
nMatchesExpectedMax = Maybe Int
forall a. Maybe a
Nothing,
                $sel:matches:AwaitAtLeastResult :: [Value]
matches = [Value] -> [Value]
forall a. [a] -> [a]
reverse [Value]
matches,
                $sel:nonMatches:AwaitAtLeastResult :: [Value]
nonMatches = [Value] -> [Value]
forall a. [a] -> [a]
reverse [Value]
nonMatches
              }
    refill :: [Value] -> App ()
refill = (Value -> App ()) -> [Value] -> App ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (IO () -> App ()
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> App ()) -> (Value -> IO ()) -> Value -> App ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> (Value -> STM ()) -> Value -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TChan Value -> Value -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan (WebSocket -> TChan Value
wsChan WebSocket
ws))

awaitNToMMatchesResult ::
  (HasCallStack) =>
  -- | Minimum number of matches
  Int ->
  -- | Maximum number of matches
  Int ->
  -- | Selection function. Exceptions are *not* caught.
  (Value -> App Bool) ->
  WebSocket ->
  App AwaitAtLeastResult
awaitNToMMatchesResult :: HasCallStack =>
Int
-> Int
-> (Value -> App Bool)
-> WebSocket
-> App AwaitAtLeastResult
awaitNToMMatchesResult Int
nMin Int
nMax Value -> App Bool
checkMatch WebSocket
ws = Int -> [Value] -> [Value] -> App AwaitAtLeastResult
go Int
0 [] []
  where
    go :: Int -> [Value] -> [Value] -> App AwaitAtLeastResult
go Int
nSeen [Value]
nonMatches [Value]
matches = do
      Int
tSecs <- (Env -> Int) -> App Int
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> Int
timeOutSeconds
      Maybe Value
mEvent <- Int -> WebSocket -> App (Maybe Value)
awaitAnyEvent Int
tSecs WebSocket
ws
      case Maybe Value
mEvent of
        Just Value
event ->
          do
            Bool
isMatch <- Value -> App Bool
checkMatch Value
event
            if Bool
isMatch
              then Int -> [Value] -> [Value] -> App AwaitAtLeastResult
go (Int
nSeen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [Value]
nonMatches (Value
event Value -> [Value] -> [Value]
forall a. a -> [a] -> [a]
: [Value]
matches)
              else Int -> [Value] -> [Value] -> App AwaitAtLeastResult
go Int
nSeen (Value
event Value -> [Value] -> [Value]
forall a. a -> [a] -> [a]
: [Value]
nonMatches) [Value]
matches
        Maybe Value
Nothing -> do
          [Value] -> App ()
refill [Value]
nonMatches
          AwaitAtLeastResult -> App AwaitAtLeastResult
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AwaitAtLeastResult -> App AwaitAtLeastResult)
-> AwaitAtLeastResult -> App AwaitAtLeastResult
forall a b. (a -> b) -> a -> b
$
            AwaitAtLeastResult
              { $sel:success:AwaitAtLeastResult :: Bool
success = Int
nMin Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
nSeen Bool -> Bool -> Bool
&& Int
nSeen Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
nMax,
                $sel:nMatchesExpectedMin:AwaitAtLeastResult :: Int
nMatchesExpectedMin = Int
nMin,
                $sel:nMatchesExpectedMax:AwaitAtLeastResult :: Maybe Int
nMatchesExpectedMax = Int -> Maybe Int
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
nMax,
                $sel:matches:AwaitAtLeastResult :: [Value]
matches = [Value] -> [Value]
forall a. [a] -> [a]
reverse [Value]
matches,
                $sel:nonMatches:AwaitAtLeastResult :: [Value]
nonMatches = [Value] -> [Value]
forall a. [a] -> [a]
reverse [Value]
nonMatches
              }
    refill :: [Value] -> App ()
refill = (Value -> App ()) -> [Value] -> App ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (IO () -> App ()
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> App ()) -> (Value -> IO ()) -> Value -> App ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> (Value -> STM ()) -> Value -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TChan Value -> Value -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan (WebSocket -> TChan Value
wsChan WebSocket
ws))

awaitNMatches ::
  (HasCallStack) =>
  -- | Number of matches
  Int ->
  -- | Selection function. Should not throw any exceptions
  (Value -> App Bool) ->
  WebSocket ->
  App [Value]
awaitNMatches :: HasCallStack =>
Int -> (Value -> App Bool) -> WebSocket -> App [Value]
awaitNMatches Int
nExpected Value -> App Bool
checkMatch WebSocket
ws = do
  AwaitResult
res <- HasCallStack =>
Int -> (Value -> App Bool) -> WebSocket -> App AwaitResult
Int -> (Value -> App Bool) -> WebSocket -> App AwaitResult
awaitNMatchesResult Int
nExpected Value -> App Bool
checkMatch WebSocket
ws
  WebSocket -> App [Value] -> App [Value]
forall a. WebSocket -> App a -> App a
withWebSocketFailureContext WebSocket
ws (App [Value] -> App [Value]) -> App [Value] -> App [Value]
forall a b. (a -> b) -> a -> b
$
    HasCallStack => AwaitResult -> App [Value]
AwaitResult -> App [Value]
assertAwaitResult AwaitResult
res

withWebSocketFailureContext :: WebSocket -> App a -> App a
withWebSocketFailureContext :: forall a. WebSocket -> App a -> App a
withWebSocketFailureContext WebSocket
ws = String -> App a -> App a
forall a. String -> App a -> App a
addFailureContext (String
"on websocket for user: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> WebSocket
ws.wsConnect.user String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"@" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> WebSocket
ws.wsConnect.domain)

assertAwaitResult :: (HasCallStack) => AwaitResult -> App [Value]
assertAwaitResult :: HasCallStack => AwaitResult -> App [Value]
assertAwaitResult AwaitResult
res = do
  if AwaitResult
res.success
    then [Value] -> App [Value]
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AwaitResult
res.matches
    else do
      let msgHeader :: String
msgHeader = String
"Expected " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show AwaitResult
res.nMatchesExpected String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" matching events, but got " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show ([Value] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length AwaitResult
res.matches) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"."
      String
details <- (String
"Details:\n" <>) (String -> String) -> App String -> App String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AwaitResult -> App String
prettyAwaitResult AwaitResult
res
      String -> App [Value]
forall a. HasCallStack => String -> App a
assertFailure (String -> App [Value]) -> String -> App [Value]
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [String
msgHeader, String
details]

awaitAtLeastNMatches ::
  (HasCallStack) =>
  -- | Minumum number of matches
  Int ->
  -- | Selection function. Should not throw any exceptions
  (Value -> App Bool) ->
  WebSocket ->
  App [Value]
awaitAtLeastNMatches :: HasCallStack =>
Int -> (Value -> App Bool) -> WebSocket -> App [Value]
awaitAtLeastNMatches Int
nExpected Value -> App Bool
checkMatch WebSocket
ws = do
  AwaitAtLeastResult
res <- HasCallStack =>
Int -> (Value -> App Bool) -> WebSocket -> App AwaitAtLeastResult
Int -> (Value -> App Bool) -> WebSocket -> App AwaitAtLeastResult
awaitAtLeastNMatchesResult Int
nExpected Value -> App Bool
checkMatch WebSocket
ws
  if AwaitAtLeastResult
res.success
    then [Value] -> App [Value]
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AwaitAtLeastResult
res.matches
    else do
      let msgHeader :: String
msgHeader = String
"Expected " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
nExpected String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" matching events, but got " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show ([Value] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length AwaitAtLeastResult
res.matches) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"."
      String
details <- (String
"Details:\n" <>) (String -> String) -> App String -> App String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AwaitAtLeastResult -> App String
prettyAwaitAtLeastResult AwaitAtLeastResult
res
      String -> App [Value]
forall a. HasCallStack => String -> App a
assertFailure (String -> App [Value]) -> String -> App [Value]
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [String
msgHeader, String
details]

awaitNToMMatches ::
  (HasCallStack) =>
  -- | Minimum Number of matches
  Int ->
  -- | Maximum Number of matches
  Int ->
  -- | Selection function. Should not throw any exceptions
  (Value -> App Bool) ->
  WebSocket ->
  App [Value]
awaitNToMMatches :: HasCallStack =>
Int -> Int -> (Value -> App Bool) -> WebSocket -> App [Value]
awaitNToMMatches Int
nMin Int
nMax Value -> App Bool
checkMatch WebSocket
ws = do
  AwaitAtLeastResult
res <- HasCallStack =>
Int
-> Int
-> (Value -> App Bool)
-> WebSocket
-> App AwaitAtLeastResult
Int
-> Int
-> (Value -> App Bool)
-> WebSocket
-> App AwaitAtLeastResult
awaitNToMMatchesResult Int
nMin Int
nMax Value -> App Bool
checkMatch WebSocket
ws
  if AwaitAtLeastResult
res.success
    then [Value] -> App [Value]
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AwaitAtLeastResult
res.matches
    else do
      let msgHeader :: String
msgHeader = String
"Expected between" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
nMin String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" to " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
nMax String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" matching events, but got " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show ([Value] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length AwaitAtLeastResult
res.matches) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"."
      String
details <- (String
"Details:\n" <>) (String -> String) -> App String -> App String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AwaitAtLeastResult -> App String
prettyAwaitAtLeastResult AwaitAtLeastResult
res
      String -> App [Value]
forall a. HasCallStack => String -> App a
assertFailure (String -> App [Value]) -> String -> App [Value]
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [String
msgHeader, String
details]

awaitMatch ::
  (HasCallStack) =>
  -- | Selection function. Should not throw any exceptions
  (Value -> App Bool) ->
  WebSocket ->
  App Value
awaitMatch :: HasCallStack => (Value -> App Bool) -> WebSocket -> App Value
awaitMatch Value -> App Bool
checkMatch WebSocket
ws = [Value] -> Value
forall a. HasCallStack => [a] -> a
head ([Value] -> Value) -> App [Value] -> App Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HasCallStack =>
Int -> (Value -> App Bool) -> WebSocket -> App [Value]
Int -> (Value -> App Bool) -> WebSocket -> App [Value]
awaitNMatches Int
1 Value -> App Bool
checkMatch WebSocket
ws

assertNoEvent ::
  (HasCallStack) =>
  Int ->
  WebSocket ->
  App ()
assertNoEvent :: HasCallStack => Int -> WebSocket -> App ()
assertNoEvent Int
to WebSocket
ws = WebSocket -> App () -> App ()
forall a. WebSocket -> App a -> App a
withWebSocketFailureContext WebSocket
ws (App () -> App ()) -> App () -> App ()
forall a b. (a -> b) -> a -> b
$ do
  Maybe Value
mEvent <- Int -> WebSocket -> App (Maybe Value)
awaitAnyEvent Int
to WebSocket
ws
  case Maybe Value
mEvent of
    Just Value
event -> String -> App ()
forall a. HasCallStack => String -> App a
assertFailure (String -> App ()) -> String -> App ()
forall a b. (a -> b) -> a -> b
$ String
"Expected no event, but got: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Value -> String
forall a. Show a => a -> String
show Value
event
    Maybe Value
Nothing -> () -> App ()
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

nPayload :: (MakesValue a) => a -> App Value
nPayload :: forall a. MakesValue a => a -> App Value
nPayload a
event = do
  [Value]
payloads <- a
event a -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"payload" App Value -> (App Value -> App [Value]) -> App [Value]
forall a b. a -> (a -> b) -> b
& App Value -> App [Value]
forall a. (HasCallStack, MakesValue a) => a -> App [Value]
asList
  [Value] -> App Value
forall (t :: * -> *) a. (HasCallStack, Foldable t) => t a -> App a
assertOne [Value]
payloads

-- | waits for an http response to satisfy a predicate
waitForResponse :: (HasCallStack) => App Response -> (Response -> App r) -> App r
waitForResponse :: forall r.
HasCallStack =>
App Response -> (Response -> App r) -> App r
waitForResponse App Response
act Response -> App r
p = do
  Int
tSecs <- (Env -> Int) -> App Int
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> Int
timeOutSeconds
  Maybe r
r <- ((forall a. App a -> IO a) -> IO (Maybe r)) -> App (Maybe r)
forall b. ((forall a. App a -> IO a) -> IO b) -> App b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO \forall a. App a -> IO a
inIO ->
    Int -> IO r -> IO (Maybe r)
forall a. Int -> IO a -> IO (Maybe a)
timeout (Int
1000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
tSecs) do
      let go :: IO r
go = do
            App r -> IO r
forall a. App a -> IO a
inIO (App Response -> (Response -> App r) -> App r
forall r.
HasCallStack =>
App Response -> (Response -> App r) -> App r
bindResponse App Response
act Response -> App r
p) IO r -> (AssertionFailure -> IO r) -> IO r
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` \(AssertionFailure
_ :: AssertionFailure) -> do
              Int -> IO ()
threadDelay Int
1000
              IO r
go
      IO r
go
  let err :: String
err = [String] -> String
unwords [String
"Expected event didn't come true after", Int -> String
forall a. Show a => a -> String
show Int
tSecs, String
"seconds"]
  App r -> (r -> App r) -> Maybe r -> App r
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> App r
forall a. HasCallStack => String -> App a
assertFailure String
err) r -> App r
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe r
r