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 Data.Foldable
import Data.Function
import Data.Functor
import Data.List
import Data.Maybe (fromMaybe)
import Data.String (IsString (fromString))
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Clock
import Network.AMQP.Extended
import Network.RabbitMqAdmin
import RunAllTests
import System.Directory
import System.Environment
import System.Exit
import System.FilePath
import Testlib.Assertions
import Testlib.Env
import Testlib.Options
import Testlib.Printing
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
env <- Maybe String -> GlobalEnv -> Codensity IO Env
mkEnv (String -> Maybe String
forall k1. k1 -> Maybe k1
Just String
testName) GlobalEnv
ge
  IO (Either String a) -> Codensity IO (Either String a)
forall a. IO a -> Codensity IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either String a) -> Codensity IO (Either String a))
-> IO (Either String a) -> Codensity IO (Either String a)
forall a b. (a -> b) -> a -> b
$
    (a -> Either String a
forall a b. b -> Either a b
Right (a -> Either String a) -> IO a -> IO (Either String a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Env -> App a -> IO a
forall a. Env -> App a -> IO a
runAppWithEnv Env
env App a
action)
      IO (Either String a)
-> [Handler (Either String a)] -> IO (Either String a)
forall a. IO a -> [Handler a] -> IO a
`E.catches` [ (SomeAsyncException -> IO (Either String a))
-> Handler (Either String a)
forall a e. Exception e => (e -> IO a) -> Handler a
E.Handler ((SomeAsyncException -> IO (Either String a))
 -> Handler (Either String a))
-> (SomeAsyncException -> IO (Either String a))
-> Handler (Either String a)
forall a b. (a -> b) -> a -> b
$ \(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. Exception e => e -> a
E.throw SomeAsyncException
e,
                    (AssertionFailure -> IO (Either String a))
-> Handler (Either String a)
forall a e. Exception e => (e -> IO a) -> Handler a
E.Handler -- AssertionFailure
                      ((String -> Either String a) -> IO String -> IO (Either String a)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Either String a
forall a b. a -> Either a b
Left (IO String -> IO (Either String a))
-> (AssertionFailure -> IO String)
-> AssertionFailure
-> IO (Either String a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AssertionFailure -> IO String
printFailureDetails),
                    (AppFailure -> IO (Either String a)) -> Handler (Either String a)
forall a e. Exception e => (e -> IO a) -> Handler a
E.Handler -- AppFailure
                      ((String -> Either String a) -> IO String -> IO (Either String a)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Either String a
forall a b. a -> Either a b
Left (IO String -> IO (Either String a))
-> (AppFailure -> IO String) -> AppFailure -> IO (Either String a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AppFailure -> IO String
printAppFailureDetails),
                    (SomeException -> IO (Either String a))
-> Handler (Either String a)
forall a e. Exception e => (e -> IO a) -> Handler a
E.Handler
                      ((String -> Either String a) -> IO String -> IO (Either String a)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Either String a
forall a b. a -> Either a b
Left (IO String -> IO (Either String a))
-> (SomeException -> IO String)
-> SomeException
-> IO (Either String a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> IO String
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
  UTCTime
tm0 <- IO UTCTime
getCurrentTime
  a
a <- IO a
action
  UTCTime
tm1 <- IO UTCTime
getCurrentTime
  (a, NominalDiffTime) -> IO (a, NominalDiffTime)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
a, UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
tm1 UTCTime
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

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

  [Test]
allTests <- IO [Test]
mkAllTests
  let tests :: [(String, String, String, App ())]
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 module0 :: String
module0 = case String
module_ of
                  (Char
'T' : Char
'e' : Char
's' : Char
't' : Char
'.' : String
m) -> String
m
                  String
_ -> String
module_
                qualifiedName :: String
qualifiedName = String
module0 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 TestOptions
opts.listTests then [(String, String, String, App ())] -> IO ()
forall x. [(String, String, String, x)] -> IO ()
doListTests [(String, String, String, App ())]
tests else [(String, String, String, App ())]
-> Maybe String -> String -> IO ()
forall x y.
[(String, x, y, App ())] -> Maybe String -> String -> IO ()
runTests [(String, String, String, App ())]
tests TestOptions
opts.xmlReport String
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
  Chan (Maybe String)
output <- IO (Chan (Maybe String))
forall a. IO (Chan a)
newChan
  let displayOutput :: IO ()
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 :: String -> IO ()
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

  Codensity IO GlobalEnv -> forall b. (GlobalEnv -> IO b) -> IO b
forall k (m :: k -> *) a.
Codensity m a -> forall (b :: k). (a -> m b) -> m b
runCodensity (String -> Codensity IO GlobalEnv
mkGlobalEnv String
cfg) ((GlobalEnv -> IO ()) -> IO ()) -> (GlobalEnv -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \GlobalEnv
genv ->
    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
      -- Currently 4 seems to be stable, more seems to create more timeouts.
      TestSuiteReport
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
        (Either String ()
mErr, NominalDiffTime
tm) <- IO (Either String ()) -> IO (Either String (), NominalDiffTime)
forall a. IO a -> IO (a, NominalDiffTime)
withTime (String -> GlobalEnv -> App () -> IO (Either String ())
forall a. String -> GlobalEnv -> App a -> IO (Either String a)
runTest String
qname GlobalEnv
genv App ()
action)
        case Either String ()
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
") -----\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])
      Chan (Maybe String) -> Maybe String -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan (Maybe String)
output Maybe String
forall k1. Maybe k1
Nothing
      Async () -> IO ()
forall (m :: * -> *) a. MonadIO m => Async a -> m a
wait Async ()
displayThread
      GlobalEnv -> IO ()
deleteFederationV0AndV1Queues GlobalEnv
genv
      TestSuiteReport -> IO ()
printReport TestSuiteReport
report
      (String -> IO ()) -> Maybe String -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (TestSuiteReport -> String -> IO ()
saveXMLReport TestSuiteReport
report) Maybe String
mXMLOutput
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((TestCaseReport -> Bool) -> [TestCaseReport] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\TestCaseReport
testCase -> TestCaseReport
testCase.result TestResult -> TestResult -> Bool
forall a. Eq a => a -> a -> Bool
/= TestResult
TestSuccess) TestSuiteReport
report.cases) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        IO ()
forall a. IO a
exitFailure

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..."
  (Maybe Text
mV0User, Maybe Text
mV0Pass) <- String -> IO (Maybe Text, Maybe Text)
readCredsFromEnvWithSuffix String
"V0"
  IO () -> Maybe (IO ()) -> IO ()
forall a. a -> Maybe a -> a
fromMaybe (String -> IO ()
putStrLn String
"No or incomplete credentials for fed V0 RabbitMQ") (Maybe (IO ()) -> IO ()) -> Maybe (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
    [String] -> RabbitMQConfig -> Text -> Text -> IO ()
deleteFederationQueues [String]
testDomains GlobalEnv
env.gRabbitMQConfigV0 (Text -> Text -> IO ()) -> Maybe Text -> Maybe (Text -> IO ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
mV0User Maybe (Text -> IO ()) -> Maybe Text -> Maybe (IO ())
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Text
mV0Pass

  String -> IO ()
putStrLn String
"Attempting to delete federation V1 queues..."
  (Maybe Text
mV1User, Maybe Text
mV1Pass) <- String -> IO (Maybe Text, Maybe Text)
readCredsFromEnvWithSuffix String
"V1"
  IO () -> Maybe (IO ()) -> IO ()
forall a. a -> Maybe a -> a
fromMaybe (String -> IO ()
putStrLn String
"No or incomplete credentials for fed V1 RabbitMQ") (Maybe (IO ()) -> IO ()) -> Maybe (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
    [String] -> RabbitMQConfig -> Text -> Text -> IO ()
deleteFederationQueues [String]
testDomains GlobalEnv
env.gRabbitMQConfigV1 (Text -> Text -> IO ()) -> Maybe Text -> Maybe (Text -> IO ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
mV1User Maybe (Text -> IO ()) -> Maybe Text -> Maybe (IO ())
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Text
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] -> RabbitMQConfig -> Text -> Text -> IO ()
deleteFederationQueues :: [String] -> RabbitMQConfig -> Text -> Text -> IO ()
deleteFederationQueues [String]
testDomains RabbitMQConfig
rc Text
username Text
password = do
  let opts :: RabbitMqAdminOpts
opts =
        RabbitMqAdminOpts
          { $sel:host:RabbitMqAdminOpts :: String
host = RabbitMQConfig
rc.host,
            $sel:port:RabbitMqAdminOpts :: Int
port = Int
0,
            $sel:adminPort:RabbitMqAdminOpts :: Int
adminPort = Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral RabbitMQConfig
rc.adminPort,
            $sel:vHost:RabbitMqAdminOpts :: Text
vHost = String -> Text
forall a. IsString a => String -> a
fromString RabbitMQConfig
rc.vHost,
            $sel:tls:RabbitMqAdminOpts :: Maybe RabbitMqTlsOpts
tls =
              if RabbitMQConfig
rc.tls
                then RabbitMqTlsOpts -> Maybe RabbitMqTlsOpts
forall k1. k1 -> Maybe k1
Just (Maybe String -> Bool -> RabbitMqTlsOpts
RabbitMqTlsOpts Maybe String
forall k1. Maybe k1
Nothing Bool
True)
                else Maybe RabbitMqTlsOpts
forall k1. Maybe k1
Nothing
          }
  AdminAPI (AsClientT IO)
client <- RabbitMqAdminOpts -> Text -> Text -> IO (AdminAPI (AsClientT IO))
mkRabbitMqAdminClientEnvWithCreds RabbitMqAdminOpts
opts Text
username Text
password
  [String] -> (String -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [String]
testDomains ((String -> IO ()) -> IO ()) -> (String -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \String
domain -> do
    Page Queue
page <- AdminAPI (AsClientT IO)
client.listQueuesByVHost (String -> Text
forall a. IsString a => String -> a
fromString RabbitMQConfig
rc.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
    [Queue] -> (Queue -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Page Queue
page.items ((Queue -> IO ()) -> IO ()) -> (Queue -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \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 (String -> Text
forall a. IsString a => String -> a
fromString RabbitMQConfig
rc.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