-- This file is part of the Wire Server implementation.
--
-- Copyright (C) 2025 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.Run (main, mainI) where

import Control.Concurrent
import Control.Exception as E
import Control.Monad
import Control.Monad.Codensity
import Control.Monad.IO.Class
import Control.Monad.Reader.Class (asks)
import Data.Default
import Data.Foldable
import Data.Function
import Data.Functor
import Data.List
import Data.Maybe
import Data.String (IsString (fromString))
import Data.String.Conversions (cs)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time
import qualified Data.Yaml as Yaml
import Network.AMQP.Extended
import Network.RabbitMqAdmin
import RunAllTests
import System.Directory
import System.Environment
import System.Exit
import System.FilePath
import System.IO.Temp (writeTempFile)
import System.Process
import Testlib.Assertions
import Testlib.Env
import Testlib.ModService (readAndUpdateConfig)
import Testlib.Options
import Testlib.Printing
import Testlib.ResourcePool (acquireResources)
import Testlib.RunServices (backendA, backendB)
import Testlib.Types
import Testlib.XML
import Text.Printf
import UnliftIO.Async
import Prelude

runTest :: String -> GlobalEnv -> App a -> IO (Either String a)
runTest :: forall a. String -> GlobalEnv -> App a -> IO (Either String a)
runTest String
testName GlobalEnv
ge App a
action = Codensity IO (Either String a) -> IO (Either String a)
forall (f :: * -> *) a. Applicative f => Codensity f a -> f a
lowerCodensity (Codensity IO (Either String a) -> IO (Either String a))
-> Codensity IO (Either String a) -> IO (Either String a)
forall a b. (a -> b) -> a -> b
$ do
  env <- Maybe String -> GlobalEnv -> Codensity IO Env
mkEnv (String -> Maybe String
forall k1. k1 -> Maybe k1
Just String
testName) GlobalEnv
ge
  liftIO $
    (Right <$> runAppWithEnv env action)
      `E.catches` [ E.Handler $ \(SomeAsyncException
e :: SomeAsyncException) -> do
                      -- AsyncExceptions need rethrowing
                      -- to prevent the last handler from handling async exceptions.
                      -- This ensures things like UserInterrupt are properly handled.
                      SomeAsyncException -> IO (Either String a)
forall a e. (HasCallStack, Exception e) => e -> a
E.throw SomeAsyncException
e,
                    E.Handler -- AssertionFailure
                      (fmap Left . printFailureDetails),
                    E.Handler -- AppFailure
                      (fmap Left . printAppFailureDetails),
                    E.Handler
                      (fmap Left . printExceptionDetails)
                  ]

pluralise :: Int -> String -> String
pluralise :: Int -> String -> String
pluralise Int
1 String
x = String
x
pluralise Int
_ String
x = String
x String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"s"

printReport :: TestSuiteReport -> IO ()
printReport :: TestSuiteReport -> IO ()
printReport TestSuiteReport
report = do
  let numTests :: Int
numTests = [TestCaseReport] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length TestSuiteReport
report.cases
      failures :: [TestCaseReport]
failures = (TestCaseReport -> Bool) -> [TestCaseReport] -> [TestCaseReport]
forall a. (a -> Bool) -> [a] -> [a]
filter (\TestCaseReport
testCase -> TestCaseReport
testCase.result TestResult -> TestResult -> Bool
forall a. Eq a => a -> a -> Bool
/= TestResult
TestSuccess) TestSuiteReport
report.cases
      numFailures :: Int
numFailures = [TestCaseReport] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TestCaseReport]
failures
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
numFailures Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"----------"
  String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
numTests String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String -> String
pluralise Int
numTests String
"test" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" run."
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
numFailures Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    String -> IO ()
putStrLn String
""
    String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> String
colored String
red (Int -> String
forall a. Show a => a -> String
show Int
numFailures String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" failed " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String -> String
pluralise Int
numFailures String
"test" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": ")
    [TestCaseReport] -> (TestCaseReport -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [TestCaseReport]
failures ((TestCaseReport -> IO ()) -> IO ())
-> (TestCaseReport -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \TestCaseReport
testCase ->
      String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
" - " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TestCaseReport
testCase.name

testFilter :: TestOptions -> String -> Bool
testFilter :: TestOptions -> String -> Bool
testFilter TestOptions
opts String
n = String -> Bool
included String
n Bool -> Bool -> Bool
&& Bool -> Bool
not (String -> Bool
excluded String
n)
  where
    included :: String -> Bool
included String
name =
      ([String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null TestOptions
opts.includeTests) Bool -> Bool -> Bool
|| (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\String
x -> String
x String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` String
name) TestOptions
opts.includeTests
    excluded :: String -> Bool
excluded String
name = (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\String
x -> String
x String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` String
name) TestOptions
opts.excludeTests

withTime :: IO a -> IO (a, NominalDiffTime)
withTime :: forall a. IO a -> IO (a, NominalDiffTime)
withTime IO a
action = do
  tm0 <- IO UTCTime
getCurrentTime
  a <- action
  tm1 <- getCurrentTime
  pure (a, diffUTCTime tm1 tm0)

printTime :: NominalDiffTime -> String
printTime :: NominalDiffTime -> String
printTime =
  String -> Float -> String
forall r. PrintfType r => String -> r
printf String
"%.02f s"
    (Float -> String)
-> (NominalDiffTime -> Float) -> NominalDiffTime -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
100.0)
    (Float -> Float)
-> (NominalDiffTime -> Float) -> NominalDiffTime -> Float
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Integer -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral :: Integer -> Float)
    (Integer -> Float)
-> (NominalDiffTime -> Integer) -> NominalDiffTime -> Float
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pico -> Integer
forall b. Integral b => Pico -> b
forall a b. (RealFrac a, Integral b) => a -> b
truncate
    (Pico -> Integer)
-> (NominalDiffTime -> Pico) -> NominalDiffTime -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pico -> Pico -> Pico
forall a. Num a => a -> a -> a
* Pico
100)
    (Pico -> Pico)
-> (NominalDiffTime -> Pico) -> NominalDiffTime -> Pico
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NominalDiffTime -> Pico
nominalDiffTimeToSeconds

printTimestamp :: UTCTime -> String
printTimestamp :: UTCTime -> String
printTimestamp = TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%FT%T.%03qZ"

main :: IO ()
main :: IO ()
main = do
  opts <- IO TestOptions
getOptions
  let f = TestOptions -> String -> Bool
testFilter TestOptions
opts
      cfg = TestOptions
opts.configFile

  allTests <- mkAllTests
  let tests =
        ((String, String, String, App ()) -> Bool)
-> [(String, String, String, App ())]
-> [(String, String, String, App ())]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(String
qname, String
_, String
_, App ()
_) -> String -> Bool
f String
qname)
          ([(String, String, String, App ())]
 -> [(String, String, String, App ())])
-> ([(String, String, String, App ())]
    -> [(String, String, String, App ())])
-> [(String, String, String, App ())]
-> [(String, String, String, App ())]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, String, String, App ()) -> String)
-> [(String, String, String, App ())]
-> [(String, String, String, App ())]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (\(String
qname, String
_, String
_, App ()
_) -> String
qname)
          ([(String, String, String, App ())]
 -> [(String, String, String, App ())])
-> [(String, String, String, App ())]
-> [(String, String, String, App ())]
forall a b. (a -> b) -> a -> b
$ [Test]
allTests [Test]
-> (Test -> (String, String, String, App ()))
-> [(String, String, String, App ())]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(String
module_, String
name, String
summary, String
full, App ()
action) ->
            let qualifiedName :: String
qualifiedName = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
module_ (String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
"Test." String
module_) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"." String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
name
             in (String
qualifiedName, String
summary, String
full, App ()
action)

  if opts.listTests then doListTests tests else runTests tests opts.xmlReport cfg

runTests :: [(String, x, y, App ())] -> Maybe FilePath -> FilePath -> IO ()
runTests :: forall x y.
[(String, x, y, App ())] -> Maybe String -> String -> IO ()
runTests [(String, x, y, App ())]
tests Maybe String
mXMLOutput String
cfg = do
  output <- IO (Chan (Maybe String))
forall a. IO (Chan a)
newChan
  let displayOutput =
        Chan (Maybe String) -> IO (Maybe String)
forall a. Chan a -> IO a
readChan Chan (Maybe String)
output IO (Maybe String) -> (Maybe String -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Just String
x -> String -> IO ()
putStr String
x IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> IO ()
displayOutput
          Maybe String
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  let writeOutput = Chan (Maybe String) -> Maybe String -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan (Maybe String)
output (Maybe String -> IO ())
-> (String -> Maybe String) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe String
forall k1. k1 -> Maybe k1
Just

  runCodensity (mkEnvs cfg) $ \(GlobalEnv
genv, Env
env) ->
    IO () -> (Async () -> IO ()) -> IO ()
forall (m :: * -> *) a b.
MonadUnliftIO m =>
m a -> (Async a -> m b) -> m b
withAsync IO ()
displayOutput ((Async () -> IO ()) -> IO ()) -> (Async () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Async ()
displayThread -> do
      -- Although migrations are run on service start up we are running them here before
      -- to prevent race conditions between brig and galley
      -- which cause flakiness and can make the complete test suite fail
      Env -> App () -> IO ()
forall a. Env -> App a -> IO a
runAppWithEnv Env
env App ()
runMigrations
      -- Currently 4 seems to be stable, more seems to create more timeouts.
      report <- ([TestSuiteReport] -> TestSuiteReport)
-> IO [TestSuiteReport] -> IO TestSuiteReport
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [TestSuiteReport] -> TestSuiteReport
forall a. Monoid a => [a] -> a
mconcat (IO [TestSuiteReport] -> IO TestSuiteReport)
-> IO [TestSuiteReport] -> IO TestSuiteReport
forall a b. (a -> b) -> a -> b
$ Int
-> [(String, x, y, App ())]
-> ((String, x, y, App ()) -> IO TestSuiteReport)
-> IO [TestSuiteReport]
forall (m :: * -> *) (t :: * -> *) a b.
(MonadUnliftIO m, Traversable t) =>
Int -> t a -> (a -> m b) -> m (t b)
pooledForConcurrentlyN Int
4 [(String, x, y, App ())]
tests (((String, x, y, App ()) -> IO TestSuiteReport)
 -> IO [TestSuiteReport])
-> ((String, x, y, App ()) -> IO TestSuiteReport)
-> IO [TestSuiteReport]
forall a b. (a -> b) -> a -> b
$ \(String
qname, x
_, y
_, App ()
action) -> do
        timestamp <- IO UTCTime
getCurrentTime
        (mErr, tm) <- withTime (runTest qname genv action)
        case mErr of
          Left String
err -> do
            String -> IO ()
writeOutput (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
              String
"----- "
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
qname
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String -> String
colored String
red String
" FAIL"
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" ("
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> NominalDiffTime -> String
printTime NominalDiffTime
tm
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"; failed at "
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> UTCTime -> String
printTimestamp UTCTime
timestamp
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
") -----\n"
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
err
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n"
            TestSuiteReport -> IO TestSuiteReport
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TestCaseReport] -> TestSuiteReport
TestSuiteReport [String -> TestResult -> NominalDiffTime -> TestCaseReport
TestCaseReport String
qname (String -> TestResult
TestFailure String
err) NominalDiffTime
tm])
          Right ()
_ -> do
            String -> IO ()
writeOutput (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
qname String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String -> String
colored String
green String
" OK" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" (" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> NominalDiffTime -> String
printTime NominalDiffTime
tm String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
")" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n"
            TestSuiteReport -> IO TestSuiteReport
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TestCaseReport] -> TestSuiteReport
TestSuiteReport [String -> TestResult -> NominalDiffTime -> TestCaseReport
TestCaseReport String
qname TestResult
TestSuccess NominalDiffTime
tm])
      writeChan output Nothing
      wait displayThread
      deleteFederationV0AndV1Queues genv
      printReport report
      mapM_ (saveXMLReport report) mXMLOutput
      when (any (\TestCaseReport
testCase -> TestCaseReport
testCase.result TestResult -> TestResult -> Bool
forall a. Eq a => a -> a -> Bool
/= TestResult
TestSuccess) report.cases) $
        exitFailure
  where
    mkEnvs :: FilePath -> Codensity IO (GlobalEnv, Env)
    mkEnvs :: String -> Codensity IO (GlobalEnv, Env)
mkEnvs String
fp = do
      g <- String -> Codensity IO GlobalEnv
mkGlobalEnv String
fp
      e <- mkEnv Nothing g
      pure (g, e)

runMigrations :: App ()
runMigrations :: App ()
runMigrations = do
  cwdBase <- (Env -> Maybe String) -> App (Maybe String)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.servicesCwdBase)
  let brig = String
"brig"
      (cwd, exe) = case cwdBase of
        Maybe String
Nothing -> (Maybe String
forall k1. Maybe k1
Nothing, String
brig)
        Just String
dir ->
          (String -> Maybe String
forall k1. k1 -> Maybe k1
Just (String
dir String -> String -> String
</> String
brig), String
"../../dist" String -> String -> String
</> String
brig)
      -- servicesCwdBase is only set for local binaries
      isLocal = Maybe String -> Bool
forall a. Maybe a -> Bool
isJust Maybe String
cwd
  getConfig <- readAndUpdateConfig def backendA Brig
  config <- liftIO getConfig
  tempFile <- liftIO $ writeTempFile "/tmp" "brig-migrations.yaml" (cs $ Yaml.encode config)
  dynDomains <- asks (.dynamicDomains)
  pool <- asks (.resourcePool)
  lowerCodensity $ do
    resources <- acquireResources (length dynDomains) pool
    let dbnames = [String
dbs | Bool
isLocal, String
dbs <- [BackendResource
backendA.berPostgresqlDBName, BackendResource
backendB.berPostgresqlDBName]] [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> (BackendResource -> String) -> [BackendResource] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (.berPostgresqlDBName) [BackendResource]
resources
    for_ dbnames $ runMigration exe tempFile cwd
    liftIO $ putStrLn "Postgres migrations finished"
  where
    runMigration :: (MonadIO m) => FilePath -> FilePath -> Maybe FilePath -> String -> m ()
    runMigration :: forall (m :: * -> *).
MonadIO m =>
String -> String -> Maybe String -> String -> m ()
runMigration String
exe String
tempFile Maybe String
cwd String
dbname = do
      let cp :: CreateProcess
cp = (String -> [String] -> CreateProcess
proc String
exe [String
"-c", String
tempFile, String
"migrate-postgres", String
"--dbname", String
dbname]) {cwd}
      (_, _, _, ph) <- IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
 -> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle))
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall a b. (a -> b) -> a -> b
$ CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess CreateProcess
cp
      void $ liftIO $ waitForProcess ph

deleteFederationV0AndV1Queues :: GlobalEnv -> IO ()
deleteFederationV0AndV1Queues :: GlobalEnv -> IO ()
deleteFederationV0AndV1Queues GlobalEnv
env = do
  let testDomains :: [String]
testDomains = GlobalEnv
env.gDomain1 String -> [String] -> [String]
forall k1. k1 -> [k1] -> [k1]
: GlobalEnv
env.gDomain2 String -> [String] -> [String]
forall k1. k1 -> [k1] -> [k1]
: GlobalEnv
env.gDynamicDomains
  String -> IO ()
putStrLn String
"Attempting to delete federation V0 queues..."
  (mV0User, mV0Pass) <- String -> IO (Maybe Text, Maybe Text)
readCredsFromEnvWithSuffix String
"V0"
  fromMaybe (putStrLn "No or incomplete credentials for fed V0 RabbitMQ") $
    deleteFederationQueues testDomains env.gRabbitMQConfigV0 <$> mV0User <*> mV0Pass

  putStrLn "Attempting to delete federation V1 queues..."
  (mV1User, mV1Pass) <- readCredsFromEnvWithSuffix "V1"
  fromMaybe (putStrLn "No or incomplete credentials for fed V1 RabbitMQ") $
    deleteFederationQueues testDomains env.gRabbitMQConfigV1 <$> mV1User <*> mV1Pass
  where
    readCredsFromEnvWithSuffix :: String -> IO (Maybe Text, Maybe Text)
    readCredsFromEnvWithSuffix :: String -> IO (Maybe Text, Maybe Text)
readCredsFromEnvWithSuffix String
suffix =
      (,)
        (Maybe Text -> Maybe Text -> (Maybe Text, Maybe Text))
-> IO (Maybe Text) -> IO (Maybe Text -> (Maybe Text, Maybe Text))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((String -> Text) -> Maybe String -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Text
forall a. IsString a => String -> a
fromString (Maybe String -> Maybe Text)
-> IO (Maybe String) -> IO (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv (String
"RABBITMQ_USERNAME_" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
suffix))
        IO (Maybe Text -> (Maybe Text, Maybe Text))
-> IO (Maybe Text) -> IO (Maybe Text, Maybe Text)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((String -> Text) -> Maybe String -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Text
forall a. IsString a => String -> a
fromString (Maybe String -> Maybe Text)
-> IO (Maybe String) -> IO (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv (String
"RABBITMQ_PASSWORD_" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
suffix))

deleteFederationQueues :: [String] -> RabbitMqAdminOpts -> Text -> Text -> IO ()
deleteFederationQueues :: [String] -> RabbitMqAdminOpts -> Text -> Text -> IO ()
deleteFederationQueues [String]
testDomains RabbitMqAdminOpts
opts Text
username Text
password = do
  client <- RabbitMqAdminOpts -> Text -> Text -> IO (AdminAPI (AsClientT IO))
mkRabbitMqAdminClientEnvWithCreds RabbitMqAdminOpts
opts Text
username Text
password
  for_ testDomains $ \String
domain -> do
    page <- AdminAPI (AsClientT IO)
client.listQueuesByVHost RabbitMqAdminOpts
opts.vHost (String -> Text
forall a. IsString a => String -> a
fromString (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"^backend-notifications\\." String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
domain String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"$") Bool
True Int
100 Int
1
    for_ page.items $ \Queue
queue -> do
      String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Deleting queue " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Queue
queue.name
      IO NoContent -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO NoContent -> IO ()) -> IO NoContent -> IO ()
forall a b. (a -> b) -> a -> b
$ AdminAPI (AsClientT IO)
-> AsClientT IO
   :- ("api"
       :> ("queues"
           :> (Capture "vhost" Text
               :> (Capture "queue" Text :> DeleteNoContent))))
forall {k} (route :: k).
AdminAPI route
-> route
   :- ("api"
       :> ("queues"
           :> (Capture "vhost" Text
               :> (Capture "queue" Text :> DeleteNoContent))))
deleteQueue AdminAPI (AsClientT IO)
client RabbitMqAdminOpts
opts.vHost Queue
queue.name

doListTests :: [(String, String, String, x)] -> IO ()
doListTests :: forall x. [(String, String, String, x)] -> IO ()
doListTests [(String, String, String, x)]
tests = [(String, String, String, x)]
-> ((String, String, String, x) -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [(String, String, String, x)]
tests (((String, String, String, x) -> IO ()) -> IO ())
-> ((String, String, String, x) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(String
qname, String
_desc, String
_full, x
_) -> do
  String -> IO ()
putStrLn String
qname

-- like `main` but meant to run from a repl
mainI :: [String] -> IO ()
mainI :: [String] -> IO ()
mainI [String]
args = do
  let projectRoot :: String
projectRoot = String
"../"
  [String] -> IO () -> IO ()
forall a. [String] -> IO a -> IO a
withArgs [String]
args (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    String -> IO () -> IO ()
forall a. String -> IO a -> IO a
withCurrentDirectory String
projectRoot (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      IO ()
main