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 (fromMaybe)
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
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

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
  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, Env)
-> forall b. ((GlobalEnv, Env) -> 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, Env)
mkEnvs String
cfg) (((GlobalEnv, Env) -> IO ()) -> IO ())
-> ((GlobalEnv, Env) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(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.
      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
        UTCTime
timestamp <- IO UTCTime
getCurrentTime
        (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
"; 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])
      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
  where
    mkEnvs :: FilePath -> Codensity IO (GlobalEnv, Env)
    mkEnvs :: String -> Codensity IO (GlobalEnv, Env)
mkEnvs String
fp = do
      GlobalEnv
g <- String -> Codensity IO GlobalEnv
mkGlobalEnv String
fp
      Env
e <- Maybe String -> GlobalEnv -> Codensity IO Env
mkEnv Maybe String
forall k1. Maybe k1
Nothing GlobalEnv
g
      (GlobalEnv, Env) -> Codensity IO (GlobalEnv, Env)
forall a. a -> Codensity IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GlobalEnv
g, Env
e)

runMigrations :: App ()
runMigrations :: App ()
runMigrations = do
  Maybe String
cwdBase <- (Env -> Maybe String) -> App (Maybe String)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.servicesCwdBase)
  let brig :: String
brig = String
"brig"
  let (Maybe String
cwd, String
exe) = case Maybe String
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)
  IO Value
getConfig <- ServiceOverrides -> BackendResource -> Service -> App (IO Value)
readAndUpdateConfig ServiceOverrides
forall a. Default a => a
def BackendResource
backendA Service
Brig
  Value
config <- IO Value -> App Value
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Value
getConfig
  String
tempFile <- IO String -> App String
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> App String) -> IO String -> App String
forall a b. (a -> b) -> a -> b
$ String -> String -> String -> IO String
writeTempFile String
"/tmp" String
"brig-migrations.yaml" (ByteString -> String
forall a b. ConvertibleStrings a b => a -> b
cs (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ Value -> ByteString
forall a. ToJSON a => a -> ByteString
Yaml.encode Value
config)
  [String]
dynDomains <- (Env -> [String]) -> App [String]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.dynamicDomains)
  ResourcePool BackendResource
pool <- (Env -> ResourcePool BackendResource)
-> App (ResourcePool BackendResource)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.resourcePool)
  Codensity App () -> App ()
forall (f :: * -> *) a. Applicative f => Codensity f a -> f a
lowerCodensity (Codensity App () -> App ()) -> Codensity App () -> App ()
forall a b. (a -> b) -> a -> b
$ do
    [BackendResource]
resources <- Int
-> ResourcePool BackendResource -> Codensity App [BackendResource]
forall (m :: * -> *) a.
(Ord a, MonadIO m, MonadMask m, HasCallStack) =>
Int -> ResourcePool a -> Codensity m [a]
acquireResources ([String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
dynDomains) ResourcePool BackendResource
pool
    let dbnames :: [String]
dbnames = [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
    [String] -> (String -> Codensity App ()) -> Codensity App ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [String]
dbnames ((String -> Codensity App ()) -> Codensity App ())
-> (String -> Codensity App ()) -> Codensity App ()
forall a b. (a -> b) -> a -> b
$ String -> String -> Maybe String -> String -> Codensity App ()
forall (m :: * -> *).
MonadIO m =>
String -> String -> Maybe String -> String -> m ()
runMigration String
exe String
tempFile Maybe String
cwd
    IO () -> Codensity App ()
forall a. IO a -> Codensity App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Codensity App ()) -> IO () -> Codensity App ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"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}
      (Maybe Handle
_, Maybe Handle
_, Maybe Handle
_, ProcessHandle
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
      m ExitCode -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m ExitCode -> m ()) -> m ExitCode -> m ()
forall a b. (a -> b) -> a -> b
$ IO ExitCode -> m ExitCode
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ExitCode -> m ExitCode) -> IO ExitCode -> m ExitCode
forall a b. (a -> b) -> a -> b
$ ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
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..."
  (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] -> RabbitMqAdminOpts -> 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] -> RabbitMqAdminOpts -> 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] -> RabbitMqAdminOpts -> Text -> Text -> IO ()
deleteFederationQueues :: [String] -> RabbitMqAdminOpts -> Text -> Text -> IO ()
deleteFederationQueues [String]
testDomains RabbitMqAdminOpts
opts Text
username Text
password = do
  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 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
    [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 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