Implement test listing (#3301)

wireapp · May 17, 2023 · fbdfeff · fbdfeff
1 parent 69499df
commit fbdfeff
Show file tree

Hide file tree

Showing 6 changed files with 47 additions and 28 deletions.
diff --git a/changelog.d/5-internal/list-tests b/changelog.d/5-internal/list-tests
@@ -0,0 +1 @@
+Implement test listing
diff --git a/integration/Setup.hs b/integration/Setup.hs
@@ -71,7 +71,7 @@ collectDescription revLines =
   let comments = reverse (map stripHaddock (takeWhile isComment revLines))
    in case uncons comments of
         Nothing -> ("", "")
-        Just (summary, _) -> (summary, unlines comments)
+        Just (summary, rest) -> (summary, unlines (dropWhile null rest))
 
 isComment :: String -> Bool
 isComment ('-' : '-' : _) = True

diff --git a/integration/test/Test/Demo.hs b/integration/test/Test/Demo.hs
@@ -7,6 +7,7 @@ import GHC.Stack
 import SetupHelpers
 import Testlib.Prelude
 
+-- | Legalhold clients cannot be deleted.
 testCantDeleteLHClient :: HasCallStack => App ()
 testCantDeleteLHClient = do
   user <- randomUser ownDomain def
@@ -17,6 +18,7 @@ testCantDeleteLHClient = do
   bindResponse (Public.deleteClient user client) $ \resp -> do
     resp.status `shouldMatchInt` 400
 
+-- | Deleting unknown clients should fail with 404.
 testDeleteUnknownClient :: HasCallStack => App ()
 testDeleteUnknownClient = do
   user <- randomUser ownDomain def

diff --git a/integration/test/Testlib/Options.hs b/integration/test/Testlib/Options.hs
@@ -8,6 +8,7 @@ import Prelude
 data TestOptions = TestOptions
   { includeTests :: [String],
     excludeTests :: [String],
+    listTests :: Bool,
     configFile :: String
   }
 
@@ -30,6 +31,7 @@ parser =
               <> help "Exclude tests matching PATTERN (simple substring match). This flag can be provided multiple times. This flag can also be provided via the TEST_EXCLUDE environment variable."
           )
       )
+    <*> switch (long "list" <> short 'l' <> help "Only list tests.")
     <*> strOption
       ( long "config"
           <> short 'c'

diff --git a/integration/test/Testlib/Printing.hs b/integration/test/Testlib/Printing.hs
@@ -20,6 +20,9 @@ red = "\x1b[38;5;9m"
 green :: String
 green = "\x1b[32m"
 
+gray :: String
+gray = "\x1b[38;5;250m"
+
 resetColor :: String
 resetColor = "\x1b[0m"
 

diff --git a/integration/test/Testlib/Run.hs b/integration/test/Testlib/Run.hs
@@ -89,25 +89,31 @@ printTime =
 
 main :: IO ()
 main = do
+  opts <- getOptions
+  let f = testFilter opts
+      cfg = opts.configFile
+
   let tests =
-        sortOn fst $
-          allTests <&> \(module_, name, _summary, _full, action) ->
+        filter (\(qname, _, _, _) -> f qname)
+          . sortOn (\(qname, _, _, _) -> qname)
+          $ allTests <&> \(module_, name, summary, full, action) ->
             let module0 = case module_ of
                   ('T' : 'e' : 's' : 't' : '.' : m) -> m
                   _ -> module_
                 qualifiedName = module0 <> "." <> name
-             in (qualifiedName, action)
+             in (qualifiedName, summary, full, action)
+
+  if opts.listTests then doListTests tests else runTests tests cfg
+
+runTests :: [(String, x, y, App ())] -> FilePath -> IO ()
+runTests tests cfg = do
   output <- newChan
   let displayOutput =
         readChan output >>= \case
           Just x -> putStr x *> displayOutput
           Nothing -> pure ()
   let writeOutput = writeChan output . Just
 
-  opts <- getOptions
-  let f = testFilter opts
-      cfg = opts.configFile
-
   genv0 <- mkGlobalEnv cfg
 
   -- save removal key to a file
@@ -123,30 +129,35 @@ main = do
       pure genv0 {gRemovalKeyPath = path}
 
   withAsync displayOutput $ \displayThread -> do
-    report <- fmap mconcat $ pooledForConcurrently tests $ \(name, action) -> do
-      if f name
-        then do
-          (mErr, tm) <- withTime (runTest genv action)
-          case mErr of
-            Left err -> do
-              writeOutput $
-                "----- "
-                  <> name
-                  <> colored red " FAIL"
-                  <> " ("
-                  <> printTime tm
-                  <> ") -----\n"
-                  <> err
-                  <> "\n"
-              pure (TestReport 1 [name])
-            Right _ -> do
-              writeOutput $ name <> colored green " OK" <> " (" <> printTime tm <> ")" <> "\n"
-              pure (TestReport 1 [])
-        else pure (TestReport 0 [])
+    report <- fmap mconcat $ pooledForConcurrently tests $ \(qname, _, _, action) -> do
+      do
+        (mErr, tm) <- withTime (runTest genv action)
+        case mErr of
+          Left err -> do
+            writeOutput $
+              "----- "
+                <> qname
+                <> colored red " FAIL"
+                <> " ("
+                <> printTime tm
+                <> ") -----\n"
+                <> err
+                <> "\n"
+            pure (TestReport 1 [qname])
+          Right _ -> do
+            writeOutput $ qname <> colored green " OK" <> " (" <> printTime tm <> ")" <> "\n"
+            pure (TestReport 1 [])
     writeChan output Nothing
     wait displayThread
     printReport report
 
+doListTests :: [(String, String, String, x)] -> IO ()
+doListTests tests = for_ tests $ \(qname, desc, full, _) -> do
+  putStrLn $ qname <> "  " <> colored gray desc
+  unless (null full) $
+    putStr $
+      colored gray (indent 2 full)
+
 -- like `main` but meant to run from a repl
 mainI :: [String] -> IO ()
 mainI args = do